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