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