Andy2483

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

¤U¸ü (174.93 KB)

2024-1-12 16:39

°õ¦æµ²ªG:

¤U¸ü (226.38 KB)

2024-1-12 16:39

Option Explicit
Sub TEST()
Dim Brr, Crr, A, Z, B, i&, R&, T$, T1$, T2$, T3$
Application.DisplayAlerts = False
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([C1], [A65536].End(3))
For i = 2 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3)
   If Not IsObject(Z(T3)) Then Set Z(T3) = CreateObject("Scripting.Dictionary"): Z(T3 & "/s") = Brr(i, 1)
   Set A = Z(T3): A(T2) = A(T2) + 1: Set Z(T3) = A: Z(T3 & "/n") = Z(T3 & "/n") + 1
Next
ReDim Crr(1 To 1000, 3)
For Each A In Z.KEYS
   If Not IsObject(Z(A)) Then GoTo A01 Else R = R + 1
   For Each B In Z(A).KEYS: T = T & "," & B & "*" & Z(A)(B): Next
   Crr(R, 0) = Z(A & "/n")
   Crr(R, 1) = A
   Crr(R, 2) = Mid(T, 2): T = ""
   Crr(R, 3) = Z(A & "/s") & "³]³Æ²§±`"
A01: Next
If R = 0 Then Exit Sub Else [E15].Resize(R, 4).Delete
With [E15].Resize(R, 4)
   .Value = Crr
   .Sort KEY1:=.Item(1), Order1:=2, Header:=2
   .Offset(10).Delete
   .Item(1).Resize(10).Merge: .Item(1) = Date
   [E15].Resize(10, 4).Borders.LineStyle = 1
End With
End Sub