返回列表 上一主題 發帖

請問如何將訂單原始資料轉成需要的?

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
1# 跳轉到 »
發表於 2019-3-25 12:55 | 顯示全部帖子
  1. Sub zz()
  2. Dim d As Object, a, k, t, b(), n&, m&, kk, tt
  3. Set d = CreateObject("scripting.dictionary")
  4. a = Range("a2:e" & [e1048576].End(3).Row)
  5. For i = 1 To UBound(a)
  6.     d("@" & a(i, 2)) = ""
  7.     k = a(i, 2) & "|" & a(i, 3)
  8.     If Not d.exists(k) Then
  9.         d(k) = Array(a(i, 4), a(i, 5), a(i, 5))
  10.     Else
  11.         t = d(k)
  12.         t(0) = t(0) & "|" & a(i, 4)
  13.         t(1) = t(1) & "|" & a(i, 5)
  14.         t(2) = t(2) + a(i, 5)
  15.         d(k) = t
  16.     End If
  17. Next
  18. k = Filter(d.keys, "@")
  19. ReDim b(1 To UBound(a), 1 To UBound(k) + 1)
  20. For j = 0 To UBound(k)
  21.     b(1, j + 1) = Mid(k(j), 2)
  22.     d.Remove (k(j))
  23.     kk = Filter(d.keys, b(1, j + 1) & "|")
  24.     For ii = 0 To UBound(kk)
  25.         t = d(kk(ii))
  26.         b(ii + 2, j + 1) = Split(kk(ii), "|")(1) & ":" & t(2)
  27.         m = m + 1
  28.         n = IIf(ii + 2 > n, ii + 2, n)
  29.     Next
  30. Next
  31. [h7].Resize(n, UBound(b, 2)) = b
  32. k = d.keys
  33. ReDim b(1 To UBound(a), 1 To m * 2): j = 0
  34. For i = 0 To UBound(k)
  35.     kk = Split(k(i), "|")
  36.     t = d(k(i))
  37.     j = j + 1
  38.     b(1, j) = kk(0)
  39.     b(2, j) = kk(1) & ":" & t(2)
  40.     For jj = 0 To 1
  41.         tt = Split(t(jj), "|")
  42.         For jjj = 0 To UBound(tt)
  43.             b(3 + jjj, j + jj) = tt(jjj)
  44.         Next
  45.     Next
  46.     n = IIf(jjj + 2 > n, jjj + 3, n)
  47.     j = j + 1
  48. Next
  49. [m7].Resize(n, UBound(b, 2)) = b
  50. Set d = Nothing
  51. End Sub
複製代碼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2024-11-19 

2016猴年全勤獎章
2#
發表於 2019-6-20 17:29 | 顯示全部帖子
  1. Sub zz()
  2. Dim d As Object, a, k, t, b(), n&, m&, kk, tt
  3. Set d = CreateObject("scripting.dictionary")
  4. a = Range("a2:e" & [e1048576].End(3).Row)
  5. For i = 1 To UBound(a)
  6.     d("@" & a(i, 2)) = ""
  7.     k = a(i, 2) & "|" & a(i, 3)
  8.     If Not d.exists(k) Then
  9.         d(k) = Array(a(i, 4), a(i, 5), a(i, 5))
  10.     Else
  11.         t = d(k)
  12.         t(0) = t(0) & "|" & a(i, 4)
  13.         t(1) = t(1) & "|" & a(i, 5)
  14.         t(2) = t(2) + a(i, 5)
  15.         d(k) = t
  16.     End If
  17. Next
  18. k = Filter(d.keys, "@")
  19. ReDim b(1 To UBound(a), 1 To UBound(k) + 1)
  20. For j = 0 To UBound(k)
  21.     b(1, j + 1) = Mid(k(j), 2)
  22.     d.Remove (k(j))
  23.     kk = Filter(d.keys, b(1, j + 1) & "|")
  24.     For ii = 0 To UBound(kk)
  25.         t = d(kk(ii))
  26.         b(ii + 2, j + 1) = Split(kk(ii), "|")(1) & ":" & t(2)
  27.         m = m + 1
  28.         n = IIf(ii + 2 > n, ii + 2, n)
  29.     Next
  30. Next
  31. [h1].Resize(n, UBound(b, 2)) = b
  32. k = d.keys
  33. ReDim b(1 To UBound(a), 1 To m * 2): j = 0
  34. For i = 0 To UBound(k)
  35.     kk = Split(k(i), "|")
  36.     t = d(k(i))
  37.     j = j + 1
  38.     b(1, j) = kk(0)
  39.     b(2, j) = kk(1) & ":" & t(2)
  40.     For jj = 0 To 1
  41.         tt = Split(t(jj), "|")
  42.         For jjj = 0 To UBound(tt)
  43.             b(3 + jjj, j + jj) = tt(jjj)
  44.             Cells(3 + jjj, j + jj + 12) = tt(jjj)
  45.         Next
  46.         n = IIf(UBound(tt) + 3 > n, UBound(tt) + 3, n)
  47.     Next
  48.     j = j + 1
  49. Next
  50. [m1].Resize(n, UBound(b, 2)) = b
  51. Set d = Nothing
  52. End Sub
複製代碼

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題