Sub 排序合并()
Dim i As Long, j As Long
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
i = Range("a1").CurrentRegion.Rows.Count
Range("a1:a" & i).UnMerge
For j = 2 To i
If Cells(j, 1) = "" Then
Cells(j, 1) = Cells(j - 1, 1)
Else
d(Cells(j, 1).Value) = ""
End If
Next
Application.AddCustomList listarray:=d.keys
Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, OrderCustom:=Application.CustomListCount + 1, key2:=Range("b1"), order2:=xlAscending, Header:=xlGuess
Application.DeleteCustomList Application.CustomListCount
For j = i To 2 Step -1
If Cells(j, 1) = Cells(j - 1, 1) And Cells(j, 2) = Cells(j - 1, 2) Then
Range(Cells(j - 1, 2), Cells(j, 2)).Merge
End If
If Cells(j, 1) = Cells(j - 1, 1) Then
Range(Cells(j - 1, 1), Cells(j, 1)).Merge
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
扫码加好友，拉您进群
全部版块
我的主页
收藏
