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