Макрос VBA для объединения повторяющихся строк на основе нескольких значений в строке

Question

У меня есть образец таблицы MS Excel:

Я пытаюсь написать макрос VBA, который позволил бы мне сравнивать строки, сравнение выполняется с использованием нескольких ячеек (A2: E2), а остальные ячейки (F2: I2) объединяют свои значения без сравнения. Я хотел бы иметь возможность сравнивать одну строку - ячейки (A2: E2) с ячейками (A3: E3), затем ячейки (A2: E2) с ячейками (A4: E4) ... когда это будет сделано, сравнение будет сливаться дубликаты - так что ячейки (Fx: Ix) также слились бы.

Конечный эффект будет выглядеть так:

До сих пор я придумал этот код, но при его запуске вылетает Excel. Любой совет будет высоко ценится.

Заранее спасибо

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

Answer 1

Сделайте это - мне пришлось изменить некоторую логику, изменить цикл For на цикл Do While, и вместо слияния мы просто удаляем строки. Я проверил это на вашем примере данных, и он работал нормально, я не уверен, как он будет работать на 1500 строк, хотя:

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