|
Sub test()
Dim Arr, Brr(1 To 30000, 1 To 8), xD, xD1, T$, T1$, n%, m%, i&, j, C
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheet1
Arr = .[a1].CurrentRegion
For i = 2 To UBound(Arr)
T = Arr(i, 2)
If T <> "" Then
xD(T & "|1") = Array(Arr(i, 4), Arr(i, 5), Arr(i, 6))
xD1(T) = 1: n = 1: T1 = T
Else
n = n + 1: xD1(T1) = n
xD(T1 & "|" & n) = Array(Arr(i, 4), Arr(i, 5), Arr(i, 6))
End If
Next
End With
With Sheet2
Arr = .[a1].CurrentRegion
For i = 2 To UBound(Arr)
T = Arr(i, 2): R = xD1(T)
For i2 = 1 To R
m = m + 1: Brr(m, 1) = Arr(i, 1)
Brr(m, 2) = Arr(i, 2)
Brr(m, 3) = xD(T & "|" & i2)(0)
Brr(m, 4) = xD(T & "|" & i2)(1)
Brr(m, 5) = Arr(i, 3)
Brr(m, 6) = xD(T & "|" & i2)(2)
Next
Next
End With
xD.RemoveAll: C = Array(1, 2, 5)
With Sheet3
.[a1].CurrentRegion.Offset(1, 0).EntireRow.Delete
With .[a2].Resize(m, 8)
.Value = Brr
.Borders.LineStyle = xlContinuous
End With
For Each j In C
For i = 1 To m
T = Brr(i, j)
If xD.Exists(T) Then
Set xD(T) = Union(xD(T), .Cells(i + 1, j))
Else
Set xD(T) = .Cells(i + 1, j)
End If
Next
For Each ky In xD.keys: xD(ky).Merge: Next
xD.RemoveAll
Next
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub
|
-
|