- ©«¤l
- 1446
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1470
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-10-21
|
ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾Ç¾Ç²ß°}¦C»P¦r¨å,(³ÎÂû¤û¤M)¤èªk¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð
°õ¦æ«e:
°õ¦æµ²ªG:
Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 3), V, Z, i&, R&, N&, T$
'¡ô«Å§iÅܼÆ
Set Z = CreateObject("Scripting.Dictionary")
'¡ô¥OZÅܼƬO ¦r¨å
Brr = Range([D2], [B65536].End(3))
'¡ô¥OBrrÅܼƬO ¤Gºû°}¦C,¥HB~DÄæÀx¦s®æȱa¤J°}¦C¤¤
With [G2].Resize(UBound(Brr), 3)
'¡ô¥H¤U¬OÃö©ó[G2]ÂX®i¦V¤UBrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹,¦V¥kÂX®i3Äæ½d³òÀx¦s®æªºµ{§Ç
.Value = Brr
'¡ô¥O¸Ó°Ï°ìÀx¦s®æȬO Brr°}¦CÈ
.Sort KEY1:=.Item(3), Order1:=2, Header:=2, _
Key2:=.Item(1), Order2:=1, Header:=2, Orientation:=1
'¡ô¥O¸Ó°Ï°ìÀx¦s®æ°µ±Æ§Ç
Brr = .Value: .ClearContents: .Offset(0, 5).ClearContents
'¡ô¥OBrr°}¦C´«¸Ë²±±Æ§Ç¹L«áªº¸Ó°Ï°ìÀx¦s®æÈ,
'¥Oµ²ªG°Ï°ìÀx¦s®æ²M°£¤º®e
End With
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é
T = Brr(i, 3): V = Z(T)
'¡ô¥OTÅܼƬO²Ä1Äæ°}¦CÈ,VÅܼƬOTÅܼƬdZ¦r¨åªºitem
If Not IsArray(V) Then V = Crr
'¡ô¦pªGVÅܼƤ£¬O°}¦C? True´N¥OVÅܼƬOCrr°}¦C
R = Z(T & "|r") + 1: Z(T & "|r") = R
'¡ô¥ORÅܼƬOTÅܼƳs±µ"|r"²Õ¦¨ªº·s¦r¦ê¬dZ¦r¨åitemÈ+1,
'¥OTÅܼƳs±µ"|r"²Õ¦¨ªº¦r¦ê¦bZ¦r¨åªºkey,©Ò¹ïÀ³ªºitem¬O RÅܼÆ
V(R, 1) = R: V(R, 2) = Brr(i, 1): V(R, 3) = Brr(i, 2)
'¡ô¥OV°}¦C¨Ì§Ç¼g¤JÈ
Z(T) = V
'¡ô¥OV°}¦C©ñ¦^Z¦r¨å¤¤
Next
For Each V In Z.KEYS
'¡ô³]³v¶µ°j°é!¥OVÅܼƬOZ¦r¨åªºkey
If Not IsArray(Z(V)) Then GoTo i01
'¡ô¦pªG¥HVÅܼƬdZ¦r¨å¦^¶Çitem¤£¬O°}¦C? True´N¸õ¨ì¼Ð¥Üi01¦ì¸mÄ~Äò°õ¦æ
Cells(2, 7 + N * 5).Resize(Z(V & "|r"), 3) = Z(V)
'¡ô¥O¦r¨å¤¤ªº°}¦Citem¼g¤JÀx¦s®æ¤¤
N = N + 1
'¡ô¥ONÅܼƲ֥[1
i01: Next
Set Z = Nothing: Erase Brr, Crr
End Sub |
|