合并重复单元格而不循环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 。

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

输出应如下所示：

编辑...假设各行中的重复值相同？ 因此，只有重复的列值才能合并。 必须有一种快速，创新的方式来进行合并。

最终输出图像：

Answer 1

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

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

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

这导致重叠

您可以在所选内容的深色阴影处看到它。

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

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