CODEWITHSUNDEEP
excelvba
Saint
Saint

Reputation: 480

VBA macro to merge duplicate rows based on multiple values in a row

I have a sample MS Excel table:

enter image description here

I am trying to write a VBA macro that would allow me to compare rows, the comparison is done using multiple cells(A2:E2), and the rest of the cells(F2:I2) would merge its values without comparison. I would like to be able to compare one row - cells(A2:E2) to cells(A3:E3), then cells(A2:E2) to cells(A4:E4)... when it is done comparing it would merge the duplicates - so that cells(Fx:Ix) would merge as well.

The final effect would look like this:

enter image description here

So far I have came up with this code, but running it crashes Excel. Any kind of advice would be much appreciated.

Thanks in advance

Sub MergeDuplicateRows()

    Dim i As Long
    Dim j As Long
    Dim RowCount As Long

    Dim sameRows As Boolean

    sameRows = True
    RowCount = Rows.Count

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For i = 1 To Range("B" & RowCount).End(xlUp).Row
        For j = 1 To 5
            If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
                sameRows = False
            End If
        Next j

        If sameRows Then
            Range(Cells(i, 1), Cells(i + 1, 1)).Merge
            Range(Cells(i, 2), Cells(i + 1, 2)).Merge
            Range(Cells(i, 3), Cells(i + 1, 3)).Merge
            Range(Cells(i, 4), Cells(i + 1, 4)).Merge
            Range(Cells(i, 5), Cells(i + 1, 5)).Merge
            Range(Cells(i, 6), Cells(i + 1, 6)).Merge
            Range(Cells(i, 7), Cells(i + 1, 7)).Merge
            Range(Cells(i, 8), Cells(i + 1, 8)).Merge
            Range(Cells(i, 9), Cells(i + 1, 9)).Merge
        End If

        sameRows = True
    Next i

    Application.DisplayAlerts = True

End Sub

Upvotes: 0

Views: 2505

Answers (1)

dwirony
dwirony

Reputation: 5450

Give this a shot - I had to change around some logic, change your For loop to a Do While loop, and instead of merging we're just deleting rows instead. I tested this on your sample data and it worked alright, I'm not sure how it will perform on 1500 rows, though:

Sub MergeDuplicateRows()

    Dim i As Long
    Dim j As Long
    Dim sameRows As Boolean

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    i = 2

    Do While Cells(i, 2).Value <> ""
        For j = 1 To 5
            If Cells(i, j).Value <> Cells(i + 1, j).Value Then
                sameRows = False
                Exit For
            Else
                sameRows = True
            End If
        Next j

        If sameRows Then
            If Cells(i, 6).Value = "" Then Cells(i, 6).Value = Cells(i + 1, 6).Value
            If Cells(i, 7).Value = "" Then Cells(i, 7).Value = Cells(i + 1, 7).Value
            If Cells(i, 8).Value = "" Then Cells(i, 8).Value = Cells(i + 1, 8).Value
            If Cells(i, 9).Value = "" Then Cells(i, 9).Value = Cells(i + 1, 9).Value

            Rows(i + 1).Delete
            i = i - 1
        End If

        sameRows = False
        i = i + 1
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

img1

Upvotes: 5

Related Questions