Sub CreateTabTwo2()
Dim cJG As Range
Dim c1 As Range, c2 As Range, rng1 As Range, rngZY As Range, rngZ As Range, rngY As Range
Dim i&, r&, r1&, rZ&, rF&, rFf&, irS&, pN, pNs&
Dim Arr1, d1, d2, rs, tmp, tmp2
Dim iTimer
iTimer = Timer
Application.StatusBar = "正在 获取数据，请稍候……"
Application.ScreenUpdating = False
With Sheet5
Arr1 = .Cells(1, 1).Resize(.Range("A65536").End(xlUp).Row + 1).Cells
ReDim arr2(LBound(Arr1, 1) To UBound(Arr1, 1))
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
r = LBound(Arr1, 1) + 1
tmp = Left(Arr1(r, 1), 18)
d1(r) = tmp
tmp2 = tmp
d2(r) = Right(Arr1(r, 1), 3)
For i = r + 1 To UBound(Arr1, 1)
tmp = Left(Arr1(i, 1), 18)
' If MsgBox(d1.Count & vbCrLf & tmp & vbCrLf & tmp2, vbOKCancel) <> vbOK Then GoTo 1000
If tmp <> tmp2 Then d1(i) = tmp: tmp2 = tmp
d2(i) = Right(Arr1(i, 1), 3)
Next
End With
Application.ScreenUpdating = True
Application.StatusBar = "正在 调整格式，请稍候……"
Application.ScreenUpdating = False
With Sheet6
…………
以前回答过类似的问题，Hi我吧，给你QQ，详细解答