Issue with Excel VBA Script (Link to thread in message)

Question

I am working on writing a VBA script to merge rows if ID's match and then sum the information in a few fields and finally delete the lower row so I only have one entry per ID.

A screen clipping of the data that I'm working with. Rows 13 and 14 are an example of ones that need to be combined.

Example Data Screenshot

I based my script off of Raystafarian's answer (latest revision) in the Q&A below:

How to combine values from multiple rows into a single row in Excel?

My script:

Sub mergeSumDelete()
Dim lastRow As Long
Dim myCell As Range

'lastRow = Cells(Rows.Count, "A").End(x1Up).Row

'Alternate way of trying to find the last row since I was having issues with the above
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For Each myCell In Range(Cells("A2"), Cells(lastRow, 1))
    If (myCell = myCell.Offset(1)) And (myCell.Offset(0, 1) = myCell.Offset(1, 1)) Then
        'Add up the data from the matching cells and put it in the top cell
        myCell.Offset(0, 2) = myCell.Offset(0, 2) + myCell.Offset(1, 2)
        myCell.Offset(0, 3) = myCell.Offset(0, 3) + myCell.Offset(1, 3)
        myCell.Offset(0, 4) = myCell.Offset(0, 4) + myCell.Offset(1, 4)

        'Delete the bottom row after data is merged
        myCell.Offset(1).EntireRow.Delete
    End If
Next
End Sub

Here's my issues that I'm having.

For the line that is assigning lastRow a value, I am getting a Runtime 1004 error. Not sure what is going on here. I tried doing it a different way and then ran into another error...
I found an alternate way to assign lastRow a value that seemed to work (or didn't throw an error at least..) Now I get an error with the For each statement, a runtime error 5 (Invalid procedure call or argument).

score 0 · Answer 1 · answered Jun 01 '17 at 20:41

I was able to find a solution/write a better script.

Sizes the selection based off of the needs for my purposes
Goes through a selection and attempts to find rows with duplicate values in the A columns. (In my case, these were vehicle ID's)
If it finds a match then it will sum the values for B, C, D with the B, C, D values of the matching ID row below
Delete the duplicate row (row below current row)
Iterates through this loop 3 times in case there are up to 4 duplicates (my data allowed this; I tried a dynamic solution but failed. Tips?)
Resizes the selection for removing extraneous rows of zero values

Any feedback is welcome, especially how to make it dynamic for an unknown number of duplicates.

Sub dataClean()
'Calls the below subs

Call compareSumDelete_v3
Call deleteZeroRows

End Sub

Sub compareSumDelete_v3()

'OPTIMIZATIONS ---------------------------------------------------------
With Application
    .ScreenUpdating = False
'END OPTIMIZATIONS -----------------------------------------------------

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("A2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("A2:D" & lastRow - 3).Select
'END OF SELECTING THE RANGE ---------------------------------------------

'COMPARING "A" CELL VALUES, SUMMING IF MATCH, DELETING OLD ENTRY --------
    Dim i As Long
    Dim j As Integer

    'Loop through three times in case there are up to 4 duplicate entries, will combine all 4 with 3 iterations
    For j = 1 To 3
        For i = 1 To Selection.Rows.Count Step 1
            If Selection.Rows(i).Columns("A") = Selection.Rows(i + 1).Columns("A") Then
                Selection.Rows(i).Columns("B") = Selection.Rows(i).Columns("B") + Selection.Rows(i + 1).Columns("B")
                Selection.Rows(i).Columns("C") = Selection.Rows(i).Columns("C") + Selection.Rows(i + 1).Columns("C")
                Selection.Rows(i).Columns("D") = Selection.Rows(i).Columns("D") + Selection.Rows(i + 1).Columns("D")

                Selection.Rows(i + 1).EntireRow.Delete

            End If
        Next i
    Next j
'END COMPARING/SUMMING/DELETING -----------------------------------------

End With

End Sub

Sub deleteZeroRows()

With Application
    .ScreenUpdating = False
    .Calculation = x1calculationmanual

'DYNAMICALLY SELECTING THE RANGE TO WORK WITH --------------------------
    Dim sht As Worksheet
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim startCell As Range

    Set sht = ActiveWorkbook.ActiveSheet
    Set startCell = Range("B2")

    'Refresh UsedRange
    ActiveWorkbook.ActiveSheet.UsedRange

    'Find Last Row
    lastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'Select Range
    sht.Range("B2:B" & lastRow).Select
'END OF SELECTING THE RANGE ---------------------------------------------

    Dim i As Long

    For i = Selection.Rows.Count To 1 Step -1
        If Selection.Rows(i) = 0 Then
            Selection.Rows(i).EntireRow.Delete
        End If
    Next i

End With
End Sub

Issue with Excel VBA Script (Link to thread in message)

1 Answers1