Andy2483

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

°õ¦æ«e:

¤U¸ü (164.58 KB)

2023-6-19 14:18

°õ¦æµ²ªG:

¤U¸ü (211.84 KB)

2023-6-19 14:19

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 250), Z, B, v&, i&, R&, C%, x%, u&, T5$, T1$
[I:IV].Delete
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([Sheet1!G4], [Sheet1!B65536].End(xlUp))
For Each B In Split([B1], ",")
   i = i + 1: Z("/" & B & "/") = i
Next
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T5 = Brr(i, 5)
   If Z("/" & T5 & "/") = "" Then GoTo i01
   B = Z(T1)
   R = Z(T1 & "/r") + 1
   If Not IsArray(B) Then
      B = Crr
      x = x + 1
      Z(T1 & "/c") = x
      Z(T1 & "/r") = 1
   End If
   B(R, 1) = Z("/" & T5 & "/")
   B(R, 2) = T5
   B(R, 3) = Brr(i, 2)
   B(R, 4) = Val(Brr(i, 6))
   Z(T1 & "/r") = R
   Z(T1) = B
i01: Next
For Each B In Z.KEYS
   If Not IsArray(Z(B)) Then GoTo v01
   u = Z(B & "/c")
   v = Z(B & "/r")
   With Cells(1, (u - 1) * 5 + 9).Resize(v + 2, 4)
      .Item(1) = "§Ç¸¹ \ " & B
      .Item(2) = "¤Ø¤o"
      .Item(3) = "½s¸¹"
      .Item(4) = "¼Æ¶q"
      .Item(2, 1).Resize(v, 4).Value = Z(B)
      .Sort KEY1:=.Item(1), Order1:=1, _
            Key2:=.Item(3), Order2:=1, Header:=1
      With .Item(2, 1).Resize(v)
         .Value = "=ROW(" & .Address(0, 0) & ")-1"
      End With
      .Item(v + 2, 2) = "¦X­p"
      .Item(v + 2, 4) = "=SUM(" & .Item(2, 4).Resize(v).Address & ")"
      .EntireColumn.AutoFit
      .Borders.LineStyle = 1
   End With
v01: Next
Set Z = Nothing: Erase Brr, Crr
End Sub