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))("¶O") = d(ar(i, 1))("¶O") + 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))("¶O")
Next

Set Rng = [N1]
Rng.Resize(1, 4) = Array("¥X³f¤H", "Á`¥ó¼Æ", "Á`­«¶q", "¦X­p¹B¶O")
  Rng.Offset(1, 0).Resize(UBound(br) + 1, 4) = br



ReDim cr(1 To d.Count)  '«Ø°}¦C 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))   '©m¦W
  j = d1(ar(i, 2))   '¤ôªG
   k = ar(i, 6)      '0¤p©ó10¤½¤ç    1¤j©ó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)   '¸ê®Æ¶K¤u§@ªí
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), "¥X³f¤H", "«~¦W", "¥ó¼Æ", "¥ó­«/ kg", "Á`­«¶q")
          Cells(Cells(Rows.Count, "Q").End(3).Row + 1, "M").Resize(1, 6) = Array("", "", "", a3, a4, a5)
    End If
  Next
Next
Next

End Sub