Andy2483

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

°õ¦æ«e:

¤U¸ü (42.27 KB)

2023-5-23 15:20

°õ¦æµ²ªG:

¤U¸ü (51.22 KB)

2023-5-23 15:21

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, T$, M%
'¡ô«Å§iÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OYÅܼƬO ¦r¨å
Brr = Range([B1], [A65536].End(xlUp))
'¡ô¥OBrrÅܼƬO ¤Gºû°}¦C,¥HA.BÄæÀx¦s®æ­È±a¤J°}¦C¤¤
ReDim Crr(1 To UBound(Brr), 1 To 100)
'¡ô¥O«Å§iCrrÅܼƬO ¤GºûªÅ°}¦C,Áa¦V½d³ò¦PBrr°}¦C,¾î¦V¯Á¤Þ¸¹1~100
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é!±q1¨ìBrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
   T = Brr(i, 1)
   '¡ô¥OTÅܼƬO i°j°é²Ä1ÄæBrr°}¦C­È
   If Y(T) = "" Then
   '¡ô¦pªGTÅܼƬdY¦r¨åªºitem­È¬O"" ?
      Y(T) = Y.Count
      '¡ô¥OY¦r¨åªºTÅܼÆkeyªºitem­È¬O Y¦r¨åkeyªº¼Æ¶q
      Crr(Y(T) \ 2 + 1, 1) = T
      '¡ô¥OCrr°}¦C©ñ¤JTÅܼÆ
      Y(T & "/C") = 1
      '¡ô¥OTÅܼƳs±µ"/C"²Õ¦¨ªº·s¦r¦ê·íkey,item¬O1,¯Ç¤JY¦r¨å¤¤
   End If
   Y(T & "/C") = Y(T & "/C") + 1
   '¡ô¥OY¦r¨å¤¤(TÅܼƳs±µ"/C"²Õ¦¨¦r¦ê)key,¨äitem­È²Ö¥[1
   '³o¬O­n¦bY¦r¨å¤¤°O¿ýTÅܼÆÄ渹
   Crr(Y(T) \ 2 + 1, Y(T & "/C")) = Brr(i, 2)
   '¡ô¥OCrr°}¦C¦b¾A·í¦ì¸m©ñ¤J i°j°é²Ä2ÄæBrr°}¦C­È
   If Y(T & "/C") > M Then
   '¡ô¦pªGY¦r¨å¤¤°O¿ýTÅܼÆÄ渹¤j©óMÅܼÆ
      M = Y(T & "/C")
      '¡ô´NÅýMÅܼƴ«¸ËÅܼÆÄ渹
      Crr(1, M) = Brr(1, 2)
      '¡ô¥O¦bCrr°}¦C²Ä1¦CMÄ渹¦ì¸m²K¥[¤@­Ó"³¡ªù¦WºÙ"¼ÐÃD
   End If
Next
[E1].Resize(Y.Count \ 2 + 1, M) = Crr
'¡ô¥OCrr°}¦C­È±q[E1]¶}©l¼g¤JÀx¦s®æ¤¤
Set Y = Nothing: Erase Brr, Crr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub