在不循环Excel的情况下合并重复单元格的最快方法 [英] fastest way to merge duplicate cells in without looping Excel

问题描述

我的单元格包含要快速合并的重复值.该表如下所示:

I have cells containing duplicate values that i want to merge quickly. The table looks like this:

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代码的某种组合来选择和合并重复的单元格范围.]

The duplicate cells ranges could be disjointed or non-adjacent cells. I want a way to quickly identify such duplicate ranges and merge them without using a For loop. [Don't know, but think there could be a fastest innovative way without loops probably using some combination of Excel array formulae and VBA code, to select and merge duplicate cell ranges.]

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

BTW the above code works fine till it shoots up the following error at line .Merge.

编辑 这是监视"窗口的快照，其中显示了 arr 内容以及 R.Address .

EDIT This is a snapshot of the Watch window showing the arr content as well as R.Address.

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

OUTPUT: Don't need any selections, this is just for demonstration purpose:

输出应如下所示:

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

EDIT... Suppose the duplicate values were same across the rows? So only duplicate columns values to be merged. There has to be an quick, innovative way to do this merge.

最终输出图像:

推荐答案

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

The issue is that your code can only find 2 adjacent cells and is not looking for a third one with this code: Set R = .Range(.Cells(I, J), .Cells(I - 1, J))

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

After the first loop it adds these 2 cells

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

After another loop it adds the next 2 cells

这导致重叠

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

And this results in an overlapping

which you can see at the darker shading of the selection.

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

I just edited some part of your code with comments, so you can see how it could be done. But I'm sure there is still space for improvements.

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的情况下合并重复单元格的最快方法的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！