singo1232001

回復 2# dou10801

singo1232001

回復 7# samwang


    Sub test()

Set d = CreateObject("scripting.dictionary")
Set d0 = CreateObject("scripting.dictionary")
  Set d1 = CreateObject("scripting.dictionary")
  rw = Cells(Rows.Count, 1).End(3).Row
   ar = Range("a2:G" & rw)
    [N:R].ClearContents
   
For i = 1 To UBound(ar)
ar(i, 6) = "": ar(i, 7) = ""
If ar(i, 4) <= 10 Then ar(i, 6) = 0: ar(i, 7) = ar(i, 3) * 15
If ar(i, 4) > 10 Then ar(i, 6) = 1: ar(i, 7) = ar(i, 5) * 2
If d.exists(ar(i, 1)) = False Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
     d(ar(i, 1))("件") = d(ar(i, 1))("件") + ar(i, 3)
      d(ar(i, 1))("重") = d(ar(i, 1))("重") + ar(i, 5)
       d(ar(i, 1))("費") = d(ar(i, 1))("費") + ar(i, 7)
    d0(ar(i, 1)) = d0.Count
     d1(ar(i, 2)) = d1.Count
Next

ReDim br(0 To d.Count - 1, 1 To 4)
For i = 0 To d.Count - 1
br(i, 1) = d.keys()(i)
br(i, 2) = d(br(i, 1))("件")
  br(i, 3) = d(br(i, 1))("重")
   br(i, 4) = d(br(i, 1))("費")
Next

Set Rng = [N1]
Rng.Resize(1, 4) = Array("出貨人", "總件數", "總重量", "合計運費")
  Rng.Offset(1, 0).Resize(UBound(br) + 1, 4) = br



ReDim cr(1 To d.Count)  '建陣列 3+2維
ReDim dr(1 To d1.Count * d.Count)
  ReDim er(0 To 1)   '
   ReDim fr(0 To 1000, 0 To 5)
    For i = 1 To UBound(cr)
     cr(i) = dr
      For j = 1 To UBound(cr(i))
        cr(i)(j) = er
        For k = 0 To 1
          cr(i)(j)(k) = fr
          cr(i)(j)(k)(0, 0) = 0
        Next
      Next
    Next

For i = 1 To UBound(ar)   '放資料
i0 = d0(ar(i, 1))   '姓名
  j = d1(ar(i, 2))   '水果
   k = ar(i, 6)      '0小於10公斤    1大於10公斤
   cr(i0)(j)(k)(0, 0) = cr(i0)(j)(k)(0, 0) + 1
    w = cr(i0)(j)(k)(0, 0)
cr(i0)(j)(k)(w, 1) = ar(i, 1)
cr(i0)(j)(k)(w, 2) = ar(i, 2)
  cr(i0)(j)(k)(w, 3) = ar(i, 3)
   cr(i0)(j)(k)(w, 4) = ar(i, 4)
    cr(i0)(j)(k)(w, 5) = ar(i, 5)
Next

For i = 1 To UBound(cr)   '資料貼工作表
For j = 1 To UBound(cr(i))
  For k = 0 To 1
    r0 = Cells(Rows.Count, Rng.Column + 1).End(3).Row + 2
    If cr(i)(j)(k)(0, 0) <> 0 Then
        a3 = 0: a4 = 0: a5 = 0
        For L = 1 To cr(i)(j)(k)(0, 0)
        a3 = a3 + cr(i)(j)(k)(L, 3)
         a4 = a4 + cr(i)(j)(k)(L, 4)
          a5 = a5 + cr(i)(j)(k)(L, 5)
        Next
        Cells(r0, Rng.Column - 1).Resize(cr(i)(j)(k)(0, 0) + 1, 6) = cr(i)(j)(k)
         Cells(r0, Rng.Column - 1).Resize(1, 6) = Array(Cells(r0, Rng.Column), "出貨人", "品名", "件數", "件重/ kg", "總重量")
          Cells(Cells(Rows.Count, "Q").End(3).Row + 1, "M").Resize(1, 6) = Array("", "", "", a3, a4, a5)
    End If
  Next
Next
Next

End Sub