[µo°Ý] ¨âºØ¤£¦P±ø¥óªº¹B¶O­pºâ¦p¦ó¦X¨Ö

dou10801

¨âºØ¤£¦P±ø¥óªº¹B¶O­pºâ¦p¦ó¦X¨Ö,Àµ½Ð«e½ú«üÂI,·P®¦.

hcm19522

(¿é¤J½s¸¹12076) googleºô§}:https://hcm19522.blogspot.com/

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (294 KB)

2023-11-29 14:28

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 5), T(2 To 4), Z, P, A, Q&, i&, R&, N&, F&, j%, x%, B$, T0$, T1$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([E2], [A65536].End(xlUp))
P = [{"¥X³f¤H","«~¦W","¥ó¼Æ","¥ó­«/ kg","Á`­«¶q"}]
For i = 1 To UBound(Brr)
   If Z(Brr(i, 1) & "") = "" Then F = F + 1: Z(Brr(i, 1) & "") = F + 1: Z(F + 1) = Brr(i, 1)
   B = IIf(Brr(i, 4) >= 10, Brr(i, 1) & "/­«­p", Brr(i, 1) & "/¥ó­p")
   Q = Z(B & Brr(i, 2) & "/" & Brr(i, 4))
   A = Z(B): R = Z(B & "\r")
   If Not IsArray(A) Then A = Crr: R = R + 1: For j = 1 To 5: A(R, j) = P(j): Next
   If Q = 0 Then
      R = R + 1: A(R, 1) = Brr(i, 1): A(R, 2) = Brr(i, 2): A(R, 4) = Brr(i, 4)
      Q = R: Z(B & Brr(i, 2) & "/" & Brr(i, 4)) = Q
   End If
   A(Q, 3) = A(Q, 3) + Val(Brr(i, 3))
   Z(B) = A: Z(B & "\r") = R
Next
[N:R].Clear: N = F + 2
With [N1].Resize(F + 1, 4)
   .Rows(1) = [{"¥X³f¤H","Á`¥ó¼Æ","Á`­«¶q","¦X­p¹B¶O"}]
   .Borders.LineStyle = xlContinuous
   .Font.Bold = True
   .Font.ColorIndex = 5
   For i = 2 To F + 1: [N1].Item(i, 1) = Z(i): Next
End With
For Each A In Z.Keys
   If Not IsArray(Z(A)) Then GoTo A01 Else R = Z(A & "\r")
   T0 = Split(A, "/")(0): T1 = Split(A, "/")(1)
   With [N1].Item(N + 1).Resize(Z(A & "\r") + 1, 5)
      .Value = Z(A): .Cells(R + 1, 1) = "¹B¶O¦X­p"
      .Cells(2, 5).Resize(R - 1) = "=" & .Cells(2, 3).Address(0, 0) & "*" & .Cells(2, 4).Address(0, 0)
      T(2) = "=SUM(P" & N + 2 & ":P" & N + R & ")"
      T(3) = "=SUM(R" & N + 2 & ":R" & N + R & ")"
      If T1 = "¥ó­p" Then
         .Cells(R + 1, 4) = "¥H¥ó­p"
         .Cells(R + 1, 3) = T(2)
         T(4) = "=" & .Cells(R + 1, 3).Address(0, 0) & "*15"
         .Cells(R + 1, 2) = Evaluate(T(4))
         Else
            .Cells(R + 1, 4) = "¥H­«­p"
            .Cells(R + 1, 5) = T(3)
            T(4) = "=" & .Cells(R + 1, 5).Address(0, 0) & "*2"
            .Cells(R + 1, 2) = Evaluate(T(4))
      End If
      .Cells(R + 1, 1).Resize(, 2).Font.Bold = True
      .Cells(R + 1, 1).Resize(, 5).Font.ColorIndex = 5
      .Cells.Borders.LineStyle = xlContinuous
      .Cells.Interior.ColorIndex = 24 + (T1 = "¥ó­p") * 4
   End With
   For j = 2 To 4: [N1].Item(Z(T0), j) = [N1].Item(Z(T0), j) + Evaluate(T(j)): Next
   N = N + R + 1
A01: Next
End Sub

dou10801

¦^´_ 7# samwang ·PÁÂsamwang¥ý¶i,¬O§Ú»Ý¨D¼Æ¦r,·P®¦.

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

samwang

¦^´_ 4# singo1232001

Singo1232001±z¦n¡A
­è­è´ú¸Õ¤F¤@¤U±zªºµ{¦¡¡A·s¼W¤H¼Æ·|¦³°ÝÃD¦p¹Ï¤ù¡A¥t¥~¦X­p¹B¶O¤]¬O¦³ÂI°ÝÃD
½Ð¦A½T»{¡AÁÂÁÂ

samwang

¦^´_ 2# dou10801

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ

dou10801

·PÁÂ:hcm19522©Msingo1232001¥ý¶i,¦¬¤U¾Ç²ß,·P®¦.

singo1232001

¦^´_ 2# dou10801

hcm19522

https://blog.xuite.net/hcm19522/twblog/590390712