合并整个工作表中的所有重复单元格 - Excel VBA

Question

我正在尝试构建一个宏，它将遍历 Activeworkbook/Activeworksheet& Range("A1:" & LastColumn & LastRow) 并合并每列中的所有重复项。我能找到的最佳起点是这篇文章 --> fastest way to merge duplicate cells in without looping Excel

但是，就像@PEH 的答案 https://stackoverflow.com/a/45739951/5079799 上的 OP cmets 一样，我在 Set R = .Range(Join(arr, ",")) 线上收到以下错误 Application defined error。

是否有人有修复和/或更好/替代方法来合并列中的重复项？

答案代码：

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

Answer 1

我在上述方法中看到的问题是它依赖于列中相邻单元格中存在的重复数据。如果重复项分散在列中怎么办？

这是一个示例，其中通过创建所有值的Dictionary 来检查每一列。由于每个值都必须是唯一的（作为键），因此重复项将被删除，并仅包含唯一键的列表。然后只需清除先前数据的列并将唯一数据复制回工作表即可。

Option Explicit

Sub RemoveColumnDupes()
    Dim lastCol As Long
    With Sheet1
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

        Dim c As Long
        For c = 1 To lastCol
            Dim columnDict As Dictionary
            Set columnDict = CreateColumnDictionary(Sheet1, c)
            If columnDict is Nothing then Exit For

            '--- clear the existing data and replace with the cleaned up data
            .Range("A1").Offset(, c - 1).Resize(.Rows.Count, 1).Clear
            .Range("A1").Offset(, c - 1).Resize(columnDict.Count, 1) = KeysToArray(columnDict)
        Next c
    End With
End Sub

Private Function CreateColumnDictionary(ByRef ws As Worksheet, _
                                        ByVal colIndex As Long) As Dictionary
    Dim colDict As Dictionary
    Dim lastRow As Long
    With ws
        lastRow = .Cells(.Rows.Count, colIndex).End(xlUp).Row
        If lastRow = 1 Then
            '--- can't create a dictionary with no data, so exit
            Set colDict = Nothing
        Else
            Set colDict = New Dictionary
            Dim i As Long
            For i = 1 To lastRow
                If Not colDict.Exists(.Cells(i, colIndex).Value) Then
                    colDict.Add .Cells(i, colIndex).Value, i
                End If
            Next i
        End If
    End With
    Set CreateColumnDictionary = colDict
End Function

Private Function KeysToArray(ByRef thisDict As Dictionary) As Variant
    Dim newArray As Variant
    ReDim newArray(1 To thisDict.Count, 1 To 1)

    Dim i As Long
    For i = 1 To thisDict.Count
        newArray(i, 1) = thisDict.Keys(i - 1)
    Next i
    KeysToArray = newArray
End Function

Answer 2

虽然我不知道我在 OP 中找到并发布的代码存在问题。我确实在https://www.extendoffice.com 上找到了很棒的解决方案，并对其进行了修改以满足我的需求，如下所示。

测试：

Sub MergeTest()
 Dim wsrng As Range
 Set wsrng = ActiveSheet.UsedRange
 Call MergeWS(wsrng)
 'Call UnMergeWS(wsrng)
End Sub

合并：

https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html

Function MergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        i = j - 1
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function

取消合并：

https://www.extendoffice.com/documents/excel/1139-excel-unmerge-cells-and-fill.html

Function UnMergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
    If Rng.MergeCells Then
        With Rng.MergeArea
            .UnMerge
            .Formula = Rng.Formula
        End With
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function

https://www.freesoftwareservers.com/display/FREES/Merge+and+UnMerge+cells+-+Excel+VBA