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 行发出以下错误。

修改这是Watch窗口的快照，显示 arr 内容以及 R.Address 。

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

输出应如下所示：

修改... 假设行中的重复值相同？因此，只有要合并的重复列值。必须有一种快速，创新的方式来进行这种合并。

最终输出图片：

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

在不循环Excel

1 个答案: