20190813xlVBA_合并同项单元格

Public Sub MergeSameItem(ByVal Rng As Range, Optional KeyColumnNo = 1, Optional MergeColumnNo = 1)
    '*Rng                       参数出入一个Range区域，注意该区域必须是已经按key先排好序的
    '*KeyColumnNo       参数表示关键字在Rng中的列号，可以传入数值，也可以传入数组表示多列均相同为一类
    '*MergeColumnNo   参数表示希望合并的Rng列号，可以传入数值，也可以传入数组表示数组指定的列都要合并单元格
    Application.DisplayAlerts = False '禁止合并单元格过程中出现警告提示
    Dim Arr As Variant
    Dim RowStart As Object
    Dim RowCount As Object
    Dim Key As String
    Dim OneKey As Variant
    Set RowStart = CreateObject("scripting.dictionary")
    Set RowCount = CreateObject("scripting.dictionary")
    Arr = Rng.Value
    If Not IsArray(KeyColumnNo) Then
        For i = LBound(Arr, 1) To UBound(Arr, 1)
            Key = CStr(Arr(i, KeyColumnNo))
            If RowStart.Exists(Key) = False Then
                RowStart(Key) = i
                RowCount(Key) = 1
            Else
                RowCount(Key) = RowCount(Key) + 1
            End If
        Next i
    Else
        For i = LBound(Arr, 1) To UBound(Arr, 1)
            Key = ""
            For Each one In KeyColumnNo
                Key = Key & "|" & CStr(Arr(i, one))
            Next
            If RowStart.Exists(Key) = False Then
                RowStart(Key) = i
                RowCount(Key) = 1
            Else
                RowCount(Key) = RowCount(Key) + 1
            End If
        Next i
    End If
    For Each OneKey In RowStart.Keys
        If Not IsArray(MergeColumnNo) Then
            Rng.Cells(RowStart(OneKey), MergeColumnNo).Resize(RowCount(OneKey), 1).Merge
        Else
            For Each one In MergeColumnNo
                Rng.Cells(RowStart(OneKey), one).Resize(RowCount(OneKey), 1).Merge
            Next
        End If
    Next OneKey
    Set RowStart = Nothing
    Set RowCount = Nothing
    Application.DisplayAlerts = True    '恢复警告提示
End Sub