|
- Sub test()
- Dim d As Object
- Dim d1 As Object
- Dim r%, i%
- Dim arr, brr(), crr()
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a1:f" & r)
- End With
- k = 0
- i = 1
- Do While i < r
- Do While Len(arr(i, 1)) = 0
- i = i + 1
- Loop
- k = k + 1
- m = 1
- Do While Len(arr(i, 1)) <> 0
- If Not d.Exists(k) Then
- m = 1
- d1(k) = i
- Else
- m = UBound(d(k), 2) + 1
- End If
- ReDim Preserve brr(1 To 6, 1 To m)
- For j = 1 To 6
- brr(j, m) = arr(i, j)
- Next
- d(k) = brr
- i = i + 1
- If i > r Then Exit Do
- Loop
- Loop
- kk = d.Keys
- tt1 = d1.Items
- ReDim crr(0 To UBound(kk))
- For i = 0 To UBound(kk)
- crr(i) = d(kk(i))(2, 1)
- Next
- n = UBound(kk)
- For i = 0 To n - 1
- p = i
- For j = i + 1 To n
- If crr(p) > crr(j) Then
- p = j
- End If
- Next
- If p <> i Then
- temp = crr(i): crr(i) = crr(p): crr(p) = temp
- temp = kk(i): kk(i) = kk(p): kk(p) = temp
- End If
- Next
- For i = 0 To UBound(kk)
- xm = kk(i)
- Cells(tt1(i), 13).Resize(UBound(d(xm), 2), UBound(d(xm))) = Application.Transpose(d(xm))
- Next
- End Sub
复制代码 |
|