- 帖子
- 262
- 主題
- 8
- 精華
- 0
- 積分
- 280
- 點名
- 16
- 作業系統
- xp
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- HK
- 註冊時間
- 2015-8-11
- 最後登錄
- 2024-3-28
|
5#
發表於 2019-6-20 17:29
| 只看該作者
- Sub zz()
- Dim d As Object, a, k, t, b(), n&, m&, kk, tt
- Set d = CreateObject("scripting.dictionary")
- a = Range("a2:e" & [e1048576].End(3).Row)
- For i = 1 To UBound(a)
- d("@" & a(i, 2)) = ""
- k = a(i, 2) & "|" & a(i, 3)
- If Not d.exists(k) Then
- d(k) = Array(a(i, 4), a(i, 5), a(i, 5))
- Else
- t = d(k)
- t(0) = t(0) & "|" & a(i, 4)
- t(1) = t(1) & "|" & a(i, 5)
- t(2) = t(2) + a(i, 5)
- d(k) = t
- End If
- Next
- k = Filter(d.keys, "@")
- ReDim b(1 To UBound(a), 1 To UBound(k) + 1)
- For j = 0 To UBound(k)
- b(1, j + 1) = Mid(k(j), 2)
- d.Remove (k(j))
- kk = Filter(d.keys, b(1, j + 1) & "|")
- For ii = 0 To UBound(kk)
- t = d(kk(ii))
- b(ii + 2, j + 1) = Split(kk(ii), "|")(1) & ":" & t(2)
- m = m + 1
- n = IIf(ii + 2 > n, ii + 2, n)
- Next
- Next
- [h1].Resize(n, UBound(b, 2)) = b
- k = d.keys
- ReDim b(1 To UBound(a), 1 To m * 2): j = 0
- For i = 0 To UBound(k)
- kk = Split(k(i), "|")
- t = d(k(i))
- j = j + 1
- b(1, j) = kk(0)
- b(2, j) = kk(1) & ":" & t(2)
- For jj = 0 To 1
- tt = Split(t(jj), "|")
- For jjj = 0 To UBound(tt)
- b(3 + jjj, j + jj) = tt(jjj)
- Cells(3 + jjj, j + jj + 12) = tt(jjj)
- Next
- n = IIf(UBound(tt) + 3 > n, UBound(tt) + 3, n)
- Next
- j = j + 1
- Next
- [m1].Resize(n, UBound(b, 2)) = b
- Set d = Nothing
- End Sub
|
|
發表於 2019-6-22 13:01
| 
