excel - 在不循环 Excel 的情况下合并重复单元格的最快方法

Question

我有包含重复值的单元格，我想快速合并它们。该表如下所示：

Sub MergeCells()
Application.DisplayAlerts = False
Dim n As Name
Dim fc As FormatCondition
Dim Rng As Range, R As Range
Dim lRow As Long
Dim I&, J&
Dim arr As Variant

ReDim arr(1 To 1) As Variant

With ThisWorkbook.Sheets("tst")
    Set Rng = .Range("A2:D11")
    lRow = Rng.End(xlDown).Row

    For J = 1 To 4
        For I = lRow To 2 Step -1   'last row to 2nd row
            If Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I - 1, J))) Then
                Set R = .Range(.Cells(I, J), .Cells(I - 1, J))
                arr(UBound(arr)) = R.Address
                ReDim Preserve arr(1 To UBound(arr) + 1)
            End If
        Next I
    Next J
    ReDim Preserve arr(1 To UBound(arr) - 1)

    Set R = .Range(Join(arr, ","))
    'MsgBox R.Areas.Count
    'R.Select
    'R.MergeCells = True
    With R
        .Merge
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    Stop
End With

Application.DisplayAlerts = True
End Sub

重复的单元格范围可能是不相交的或不相邻的单元格。我想要一种方法来快速识别此类重复范围并在不使用 For 循环的情况下合并它们。[不知道，但认为可能有一种最快的创新方法，无需循环，可能使用 Excel 数组公式和 VBA 代码的某种组合来选择和合并重复的单元格区域。]

顺便说一句，上面的代码可以正常工作，直到它在.Merge行出现以下错误。

编辑这是显示arr内容以及R.Address 的 Watch 窗口的快照。

输出： 不需要任何选择，这只是为了演示目的：

输出应如下所示：

编辑... 假设行中的重复值相同？所以只有重复的列值被合并。必须有一种快速、创新的方式来进行这种合并。

最终输出图像：

Answer 1

问题是您的代码只能找到 2 个相邻的单元格，并且没有使用此代码查找第三个单元格：Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

在第一个循环之后，它添加了这两个单元格

在另一个循环之后，它添加了接下来的 2 个单元格

这会导致重叠 ，您可以在选择的较暗阴影处看到重叠。

我刚刚用注释编辑了你的代码的一部分，所以你可以看到它是如何完成的。但我确信仍有改进的空间。

Sub MergeCellsNew()
    Application.DisplayAlerts = False
    Dim n As Name
    Dim fc As FormatCondition
    Dim Rng As Range, R As Range
    Dim lRow As Long
    Dim I&, J&
    Dim arr As Variant

    ReDim arr(1 To 1) As Variant

    With ThisWorkbook.Sheets("tst")
        Set Rng = .Range("A2:D11")
        lRow = Rng.End(xlDown).Row

        For J = 1 To 4
            I = 2 'I = Rng.Row   to automatically start at the first row of Rng
            Do While I <= lRow
                Set R = .Cells(I, J) 'remember start cell

                'run this loop as long as duplicates found next to the start cell
                Do While Trim(UCase(.Cells(I, J))) = Trim(UCase(.Cells(I + 1, J)))
                    Set R = R.Resize(R.Rows.Count + 1) 'and resize R + 1
                    I = I + 1
                Loop

                'now if R is bigger than one cell there are duplicates we want to add to the arr
                'this way single cells are not added to the arr
                If R.Rows.Count > 1 Then
                    arr(UBound(arr)) = R.Address
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                I = I + 1
            Loop
        Next J
        ReDim Preserve arr(1 To UBound(arr) - 1)

        Set R = .Range(Join(arr, ","))
        With R
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        Stop
    End With

    Application.DisplayAlerts = True
End Sub