How can I delete 123572 rows faster in VBA? - excel

I have a file with more then 1 sheet, where in the Reports Sheet I want to filter by ASBN products and then delete them, because I already processed it in another sheet, so I need to delete the initial ones in order to paste back the processed one.
Idea is that this deleting code which is working, but is taking for at least 20 minutes, because I want to delete 123 572 rows, do you have any idea how could I make this work faster?
I also tried to clear contents first and then to delete empty rows, but it's the same.
Here you find the code:
Public Sub Remove_ABSN()
Dim area As String
Dim start As Long
area = "ABSN"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
start = Worksheets("Reports").Cells(Cells.Rows.Count, 1).End(xlUp).Row
Worksheets("Reports").Range("$A$2:$AN" & start).AutoFilter Field:=8, Criteria1:=area, Operator:=xlFilterValues
Worksheets("Reports").Range("$A$2:$AN$" & start).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheets("Reports").ShowAllData
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

I think AutoFilter will be the fastest way to do it. Here are two sample scripts to try. You can see for yourself which one is faster.
Public Sub UnionDeleteRowsFast()
' Careful...delete runs on Sheet1
Dim sh2 As Worksheet
Set sh2 = Sheets("Sheet1")
Dim lastrow As Long
Dim Rng As Range
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = lastrow To 2 Step -1
If Cells(i, 2).Value = "Delete" Then
If Rng Is Nothing Then
Set Rng = Range("B" & i)
Else
Set Rng = Union(Rng, Range("B" & i))
End If
End If
Next
If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub
Sub AutoFilterDeleteRowsFast()
' Careful...delete runs on ActiveSheet
With ActiveSheet
.AutoFilterMode = False
With Range("B4", Range("B" & Rows.Count).End(xlUp))
.AutoFilter 1, "*Delete*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub

There is a way that is much faster.
Suppose a table of 100,000 lines (A1:B100001) with headers in line 1. Then delete condition refers to just 1 column (B).
One needs a auxiliar column (A) just to count the lines in the original order. Here I use autofill function.
So one can sort the table and after restore the original order.
Below there is a complete example, that generates randomly numbers from 1 to 10 (it's slow!), and after quickly delete all lines with values 3
Sub EraseValue()
Application.ScreenUpdating = False
Dim i As Long
Dim T1 As Single ' milisecs after booting (Start)
Dim T2 As Single ' milisecs after booting (End)
Dim LIni As Variant ' Initial line to delete
Dim LEnd As Variant ' Final line to delete
Const Fin = 100000 ' Lines in the table
Const FinStr = "100001" ' Last line (string)
Randomize (GetTickCount()) ' Seed of random generation
For i = 1 To Fin
Cells(i + 1, "B") = Int(Rnd() * 10 + 1) ' Generates from 1 to 10
If i Mod 100 = 0 Then Application.StatusBar = i
DoEvents
Next i
Application.StatusBar = False
Dim Table As Range
Dim Colu As Range
T1 = GetTickCount() ' Initial time
Cells(2, "A") = 1 ' Starting value
Cells(3, "A") = 2 ' Step
' Fill from 1 to 100,000 step 1
Range("A2:A3").AutoFill Destination:=Range("A2:A" & FinStr)
' Order by condition column
Table.Sort Key1:=Cells(1, "B"), Header:=xlYes
'One needs delete lines with column B = 3
'LIni: Search key that not exceed value 2 in the column
' (2 is immediately previous value)
'LEnd: Search key that not exceed value 3 in the column
'LIni and LFim is relative to 2 so add 1 for skip the header
'Add more 1 to Lini in order to get the first value in the column >= key
'
LIni = Application.Match(2, Colu, 1) + 2
LEnd = Application.Match(3, Colu, 1) + 1
If IsError(LIni) Or IsError(LEnd) Or LEnd < LEnd Then
MsgBox ("There is no lines to delete")
End
End If
Range(Rows(LIni), Rows(LEnd)).Delete (xlUp) ' Delete lines
Table.Sort Key1:=Cells(1, "A"), Header:=xlYes ' Restore initial order
T2 = GetTickCount() ' Get the final time
MsgBox ("Elapsed milisecs: " + Format((T2 - T1), "0"))
End Sub
In my old computer, it take a little bit more that 0.5 secs with 100,000 lines.
If one has a condition that involves 2 columns or more, one need to create an another auxiliary column with a formula that concatenate these columns related do desired condition and run the match in this column. The formula needs to usage relative references. For instance (assuming that the data of column C are string and is already filled with a header).
Cells(1,4) = "NewCol" ' New column D
Dim NewCol As Range
Set NewCol = Range("D2:D" & FinStr)
' Two previous columns concatenated. In line 2
' the formula would be "=Format(B2,"0")+C2" (B2 is a number)
NewCol.FormulaR1C1 = "=Format(RC[-2],"0") & RC[-1]"
NewCol.Copy
NewCol.PasteSpecial(XlValues) ' Convert all formulas to values
Application.CutCopyMode=false
So one usages the column D instead column B

Related

VBA Copy and paste entire row if cell matches list of IDs, but do not paste if list contains blank cell or cell with ""

I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub

Split rows based on number of linebreaks in cell VBA

I have a financial data with serial numbers linked to asset. The serial numbers are listed in cell through line breaks, i.e. there could 3,4,5 etc. serial no in a cell. So, the idea is copy and insert rows based on how many serial numbers are linked to asset in selected range. i.e. if there 4 serial no, then row should be split into 4 rows. The issue my code is that once I'm selected the range to be split, no matter that 3 or more serial numbers exist in first row it's slit into two rows, but the rest cells in range are split correctly. Not sure why the cycle within first cell in a range ends wrong.
Public Sub separate_line_range()
Dim target_col As Range
myTitle = "Select cells to be split"
Set target_col = Application.Selection
Set target_col = Application.InputBox("Select a range of cells that you want to split", myTitle, target_col.Address, Type:=8)
ColLastRow = target_col
Application.ScreenUpdating = False
For Each rng In target_col
If InStr(rng.Value, vbLf) Then
rng.EntireRow.Copy
rng.EntireRow.Insert
rng.Offset(-1, 0) = Mid(rng.Value, 1, InStr(rng.Value, vbLf) - 1)
rng.Value = Mid(rng.Value, Len(rng.Offset(-1, 0).Value) + 2, Len(rng.Value))
End If
Next
ColLastRow2 = target_col
For Each Rng2 In target_col
If Len(Rng2) = 0 Then
Rng2.EntireRow.Delete
End If
Next
Application.ScreenUpdating = True
End Sub
Please find imagine below:
I don't exactly know your task, so I put something relatively close to your task.
The issue of not correctly loop through all row is because the "RNG" you selected will not be resized after each insert row.
e.g. You are selecting row A1:C20, and there are two row added. Now the #19 and #20 are now A21:C21 & A22:C22. But the RNG is still A1:C20. The final two row will not be within the loop.
To solve your issue,
Use For i = LastRow to First Row Step -1 (Next) instead of For Each (Loop)
Here is something I do similar to your task (What I believe)
Sub Insertrow()
Dim i As Integer
Dim Lastrow As Integer
Lastrow = Worksheets("FMS1").Cells(1, 12)
For i = Lastrow To 1 Step -1
If Worksheets("FMS1").Range("J" & i) <> Worksheets("FMS1").Range("J" & i + 1) Then
Worksheets("FMS1").Range("J" & i + 1).EntireRow.Insert
Else
End If
Next
End Sub
Imagine the following data
and the following code
Option Explicit
Public Sub SplitLineBreaksIntoCells()
Const MyTitle As String = "Select cells to be split" ' define it as constant
Dim TargetCol As Range
On Error Resume Next ' next line errors if user presses cancel
Set TargetCol = Application.InputBox("Select a range of cells that you want to split", MyTitle, Application.Selection.Address, Type:=8)
On Error GoTo 0
If TargetCol Is Nothing Then
' User pressed cancel
Exit Sub
End If
Dim iRow As Long
For iRow = TargetCol.Rows.Count To 1 Step -1 ' loop from bottom to top when adding rows or row counting goes wrong.
Dim Cell As Range ' get current cell
Set Cell = TargetCol(iRow)
Dim LinesInCell() As String ' split data in cell by line break int array
LinesInCell = Split(Cell.Value, vbLf)
Dim LinesCount As Long ' get amount of lines in that cell
LinesCount = UBound(LinesInCell) + 1
' insert one cell less (one cell can be re-used)
Cell.Resize(RowSize:=LinesCount - 1).EntireRow.Insert Shift:=xlShiftDown
' inert the values from the spitted array
Cell.Offset(RowOffset:=-LinesCount + 1).Resize(RowSize:=LinesCount).Value = Application.Transpose(LinesInCell)
Next iRow
End Sub
You will get this as result:

Copying rows to a wksheet based on the value in a specific column isn't applying to my whole spreadsheet

I'm looping over values in Column B of the current worksheet. If the value's length is 8 characters, copy the WHOLE row to another sheet.
It is kind of working, but I'm missing around a hundred rows that should have been copied.
I guess it's to do with the format of the cell values in Column B. There are some that are just Text headers which will definitely not meet the criteria. The ones that it should copy are all in this format (Column B):
6008571X
60088242
....
The rows I'm interested in have 8 characters in Column B. The problem is that some of them might be formatted as numbers some as text (or perhaps preceded by ').
Sub aims()
Dim i As Long
'Get the address of the first non blank cell in Row B from the bottom
MyFirstBlankAddress = Range("B1048576").End(xlUp).Offset(1, 0).Address
'Extract the number from the address to get the row number
MyRowNumber = Split(MyFirstBlankAddress, "$")(2)
For i = 1 To MyRowNumber
With Range("B" & i)
If Len(.Value) = 8 Then .EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
Next i
End Sub
I was expecting 410 rows copied, while only 276 got copied.
EDIT: I have been reading your answers/suggestions and testing stuff. I've found out that the problem lies elsewhere. My original code identifies the rows in a correct way, it's something to do with copying.
If I change my code to just highlight the matching rows, it matches all the right rows:
If Len(.Value) = 8 Then .EntireRow.Interior.Color = 5296274
I'm sure there is a better way to do the copy/paste, which is where your issue is, but the below works.
Sub aims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(what:="*", after:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=Sheets(2).Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
You can try something like this. The below code attempts to copy everything at once instead of having many instances of copy/paste. The two tests are seeing if the trimmed value has a character length of 8 OR if the trimmed value has a character length of 9 but the last character is the apostrophe. If either of these criteria are met, we will add that cell to a Union.
Once the code has looped through all rows, it will copy the entire union at all once
Option Explicit
Sub shooter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim LR As Long, i As Long, Add As Boolean, CopyMe As Range
Dim x As Range
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For Each x In ws.Range("B2:B" & LR)
Add = False
If Len(Trim(x)) = 8 Then
Add = True
ElseIf Len(Trim(x)) = 9 And Right(Trim(x), 1) = "'" Then
Add = True
End If
If Add Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, x)
Else
Set CopyMe = x
End If
End If
Next x
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=Sheets(2).Range(“A1”)
End If
End Sub

Excel macro to paste transpose based on repeated values in another column

The first set of data is a snippet of may data (running into thousands of rows) in the first two columns.
The first column has repeated ticket numbers with different status. I want to have a unique row for each ticket and corresponding columns to have the various status(a transpose like). See below illustration:
Incident Number Measurement Status
INCIN0001910583 Detached
INCIN0001910583 Missed
INCIN0001908104 Detached
INCIN0001908104 Detached
INCIN0001908104 Missed
INCIN0001914487 Met
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Detached
INCIN0001908444 Met
INCIN0001910624 Met
INCIN0001910575 Detached
INCIN0001910575 Met
I'm looking for a macro (or formula) to achieve something like this:
INCIN0001910583 Detached Missed
INCIN0001908104 Detached Detached Missed
INCIN0001914487 Met
INCIN0001908444 Detached Detached Detached Met
INCIN0001910624 Met
INCIN0001910575 Detached Met
As Tom pointed out, below is the recorded macro I have been using to achieve this, pasting the transpose in the first occurrence of the unique Incident Number(column A) and then manually removing the blanks.(however it takes ages to complete it for thousands of rows)
Sub transpose_paste()
'
' transpose_paste Macro
'
' Keyboard Shortcut: Ctrl+t
'
Selection.Copy
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
Cells(ActiveCell.Row, 14).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
End Sub
I'm not sure I understand why Tom gave you the advice he did. This wouldn't be a very good idea to get a recorded macro from because of the non-dynamic nature of recorded code as opposed to the dynamic nature of your data.
Here are two options. The first being what you asked for (run the 'PivotData_All' routine), the other being if you want to exclude non-unique items from the subsequent columns of data (run the 'PivotData_UniquesOnly' routine).
Sub PivotData_All()
With Worksheets("Sheet1")
Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), False)
End With
End Sub
Sub PivotData_UniquesOnly()
With Worksheets("Sheet1")
Call PivotData(.Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row), True)
End With
End Sub
Sub PivotData( _
ByVal IncidentData As Range, _
Optional ByVal UniquesOnly As Boolean = False _
)
'
' Take data from a given range and pivot out data based on first column being incident numbers, second column being
' measurement status. Each unique incident will be given its own row and the measurment status will be pivoted out
' along columns on a new sheet.
'
' Syntax: PivotData(UniquesOnly)
'
' Parameters: IncidentData. Range. Required. A two-column set of data. Left column is incident number, right column
' is measurement status.
' UniquesOnly. Boolean. Optional. Specify whether second column of data should contain only unique values
' or not. If omitted False is passed.
'
Dim Incidents As Collection
Dim NewSheet As Worksheet
Dim Incident() As Variant
Dim IncidentItem As Variant
Dim IncidentTempValues() As Variant
Dim IncidentStep As Long
Dim IncidentMatch As Long
Dim IncidentKey As String
'// Change these as necessary
'// Get values into an array to start
IncidentTempValues = IncidentData.Value
'// Iterate through array to get unique values, append all measurements to individual array
Set Incidents = New Collection
For IncidentStep = LBound(IncidentTempValues, 1) To UBound(IncidentTempValues, 1)
IncidentKey = CStr(IncidentTempValues(IncidentStep, 1))
If InCollection(Incidents, IncidentKey) = False Then
Incident = Array(IncidentKey, IncidentTempValues(IncidentStep, 2))
Incidents.Add Incident, IncidentKey
Else
Erase Incident
Incident = Incidents.Item(IncidentKey)
IncidentMatch = 0
If UniquesOnly Then
On Error Resume Next
IncidentMatch = WorksheetFunction.Match(IncidentTempValues(IncidentStep, 2), Incident, 0)
On Error GoTo 0
End If
If IncidentMatch = 0 Then
ReDim Preserve Incident(LBound(Incident) To UBound(Incident) + 1)
Incident(UBound(Incident)) = IncidentTempValues(IncidentStep, 2)
Incidents.Remove IncidentKey
Incidents.Add Incident, IncidentKey
End If
End If
Next IncidentStep
'// Put values into new sheet
If Incidents.Count > 0 Then
Set NewSheet = Worksheets.Add
IncidentStep = 1
For Each IncidentItem In Incidents
NewSheet.Cells(IncidentStep, 1).Resize(1, UBound(IncidentItem) - LBound(IncidentItem) + 1).Value = IncidentItem
IncidentStep = IncidentStep + 1
Next IncidentItem
NewSheet.Cells.EntireColumn.AutoFit
End If
'// Message user upon completion
If Incidents.Count > 0 Then
MsgBox "New sheet created ('" & NewSheet.Name & "') with " & Incidents.Count & " record(s).", vbInformation, "Complete"
Else
MsgBox "Unable to create incident data.", vbExclamation, "Whoops!"
End If
End Sub
Public Function InCollection(CheckCollection As Collection, CheckKey As String) As Boolean
'
' Returns True if the specified key is found in the specified collection.
'
' Syntax: InCollection(CheckCollection,CheckKey)
'
' Parameters: CheckCollection. Collection. Required. The collection to search in.
' CheckKey. String. Required. The string key to search in collection for.
'
On Error Resume Next
InCollection = CBool(Not IsEmpty(CheckCollection(CheckKey)))
On Error GoTo 0
End Function
This would need to go into a standard module. Let us know if you need additional assistance with this.
Regards,
Zack Barresse
This procedure assumes the following:
Data ranges starts at A1, includes two columns and it's a continuous range of data (i.e. no blank rows in between, and column C is blank
Output data starts at D1
Sub Rng_List_Unique_Records()
Dim vSrc As Variant, sKey As String
Dim sStatus As String, aStatus As Variant
Dim lRow As Long, l As Long
With ThisWorkbook.Sheets(1)
Application.Goto .Cells(1), 1
Rem Set Array with Source Range Data
vSrc = .Cells(1).CurrentRegion.Value2
Rem Extract Unique Items
For l = 1 To UBound(vSrc)
If vSrc(l, 1) = sKey Then
Rem Same Incident - Add Measurement
sStatus = sStatus & ";" & vSrc(l, 2)
Else
If sStatus <> Empty Then
Rem Enter Measurements for Prior Incident
aStatus = Split(sStatus, ";")
.Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus
End If
Rem New Incident
lRow = 1 + lRow
sKey = vSrc(l, 1)
.Cells(lRow, 4) = sKey
sStatus = vSrc(l, 2)
End If: Next
Rem Enter Measurements for Last Incident
aStatus = Split(sStatus, ";")
.Cells(lRow, 5).Resize(, 1 + UBound(aStatus)) = aStatus
Rem Output Range Columns AutoFit
.Cells(4).CurrentRegion.EntireColumn.AutoFit
End With
End Sub
Suggest to visit the following pages to obtain a deeper understanding of the resources used:
Variables & Constants, Application Object (Excel), Excel Objects
With Statement, For Each...Next Statement, If...Then...Else Statement
Range Object (Excel), Worksheet Object (Excel)
Nevertheless let me know of any questions about the procedure
It's been a slow day so..... This will do what you want using vba. You could also achieve this as Scott has said above with formulas or even using a pivot table. However by the looks of the question you're looking for something dynamic which will expand automatically to include new incidents which the formulas won't do easily.
I've over commented it in the hopes that you will easily be able to understand for future modifications. This is probably not the only way of doing it and not necessarily the best.
Option Explicit
Sub transposeAndCombine()
' Declare all of the variable names and types we will be using
Dim inc As Object
Dim c As Integer: Dim i As Integer
Dim rng As Range
Dim f
Dim ws as worksheet
' Turns off screen updating - good practice for the majority of vba macros
Application.ScreenUpdating = False
' Declare worksheet
set ws = ThisWorkbook.Sheets("Sheet1")
' Change Sheet1 to relevant sheet
' You'll also need to change all 4's that are detailed below to your relevant destination.
' I put all the processed data into Column D in my example
' starting from row 2 to leave a row for a header
With ws
' Declare range that we are going to be considering (where the raw data is)
Set rng = Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
' Loop through that data
For Each inc In rng
' Find if data exists in destination
Set f = .Columns(4).Find(inc.Value, LookIn:=xlValues)
' If it exists assign the row number to a variable, if not add it to the end
If Not f Is Nothing Then
i = f.Row
Else
i = .Cells(.Rows.Count, 4).End(xlUp).Row + 1
.Cells(i, 4) = inc.Value
End If
' find last column that has been used
c = .Cells(i, .Columns.Count).End(xlToLeft).Column + 1
' add the Status value to the row
.Cells(i, c) = inc.Offset(0, 1)
' Loop back for next data entry
Next inc
End With
' Turn back on screen updating for normal behaviour
Application.ScreenUpdating = True
End Sub

How to delete a row if it contains a string?

I have only one column of data. I need to write a macro that would go through all the values and delete all rows that contain the word "paper".
A B
1 678
2 paper
3 3
4 09
5 89
6 paper
The problem is that the number of rows is not fixed. Sheets may have different number of rows.
Here is another simple macro that will remove all rows with non-numeric values in column A (besides row 1).
Sub DeleteRowsWithStringsInColumnA()
Dim i As Long
With ActiveSheet '<~~ Or whatever sheet you may want to use the code for
For i = .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1).Row To 2 Step -1 '<~~ To row 2 keeps the header
If IsNumeric(.Cells(i, 1).Value) = False Then .Cells(i, 1).EntireRow.Delete
Next i
End With
End Sub
If you're confident that the rows in question would always contain "paper" specifically and never any other string, you should match based on the value paper rather than it being a string. This is because, particularly in Excel, sometimes you may have numbers stored as strings without realizing it--and you don't want to delete those rows.
Sub DeleteRowsWithPaper()
Dim a As Integer
a = 1
Do While Cells(a, 1) <> ""
If Cells(a, 1) = "paper" Then
Rows(a).Delete Shift:=xlUp
'Row counter should not be incremented if row was just deleted
Else
'Increment a for next row only if row not deleted
a = a + 1
End If
Loop
End Sub
The following is a flexible macro that allows you to input a string or number to find and delete its respective row. It is able to process 1.04 million rows of simple strings and numbers in 2.7 seconds.
Sub DeleteRows()
Dim Wsht As Worksheet
Dim LRow, Iter As Long
Dim Var As Variant
Var = InputBox("Please specify value to find and delete.")
Set Wsht = ThisWorkbook.ActiveSheet
LRow = Wsht.Cells(Rows.Count, 1).End(xlUp).Row
StartTime = Timer
Application.ScreenUpdating = False
With Wsht
For Iter = LRow To 1 Step -1
If InStr(.Cells(Iter, 1), Var) > 0 Then
.Cells(Iter, 1).EntireRow.Delete
End If
Next Iter
End With
Application.ScreenUpdating = True
Debug.Print Timer - StartTime
End Sub

Resources