Andy2483

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

°õ¦æ«e:

¤U¸ü (98.74 KB)

2023-4-18 09:51

°õ¦æµ²ªG:

¤U¸ü (114.3 KB)

2023-4-18 09:51

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), Y, Z, R&, R1&, i&, j&
Dim xR As Range, TT$, T1$, B$, A$
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([B1], Cells(Rows.Count, "A").End(3)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then R = 1: Crr(R, 1) = "¤é´Á": Crr(R, 2) = "¶µ¥Ø": Crr(R, 3) = "Á`¼Æ"
   Z = Split(Brr(i, 2), vbLf): T1 = Brr(i, 1)
   For j = 0 To UBound(Z)
      A = Split(Z(j), "-")(0): B = Split(Z(j), "-")(1): TT = T1 & "|" & B
      If Y(TT) = "" Then
         R = R + 1: R1 = R: Y(TT) = R1
         Crr(R1, 1) = Brr(i, 1): Crr(R1, 2) = B
         Else
         R1 = Y(TT)
      End If
      Crr(R1, 3) = Crr(R1, 3) + Val(A)
   Next
Next
With [J1].Resize(R, 3)
   .EntireColumn.ClearContents
   .Value = Crr
   .Sort KEY1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr, Crr, Z
End Sub