Question

我有一个示例MS Excel表：

我正在尝试使用多个单元格（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

基于一行中的多个值合并重复的行

1 个答案: