- ©«¤l
- 1447
- ¥DÃD
- 40
- ºëµØ
- 0
- ¿n¤À
- 1471
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Excel 2010 & 2016
- ¾\ŪÅv
- 50
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥xÆW
- µù¥U®É¶¡
- 2020-7-15
- ³Ì«áµn¿ý
- 2024-12-5
|
¦^´_ 1# PD961A
ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹¥DÃD½m²ß°}¦C. ¨Ï¥Î¤j¤p·|µø»Ýn°ÊºA¼W¥[ªº°}¦C»P ¦r¨å,
¾Ç²ß¨ì«Ü¦hª¾ÃÑ,ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð
°õ¦æ«e:
°õ¦æµ²ªG:
Option Explicit
Sub TEST()
Dim Brr, T, Y, Z, A, xR As Range, xU As Range
'¡ô«Å§iÅܼÆ:(Brr,T,Y,Z,A)¬O³q¥Î«¬ÅܼÆ,(xR,xU)¬OÀx¦s®æÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OY³o³q¥Î«¬ÅܼƬO ¦r¨å
Set Z = CreateObject("System.Collections.ArrayList")
'¡ô¥OZ³o³q¥Î«¬ÅܼƬO ¨Ï¥Î¤j¤p·|µø»Ýn°ÊºA¼W¥[ªº°}¦C
Set xR = [A2:H17]: Brr = xR
'¡ô¥OxR³oÀx¦s®æÅܼƬO [A2:H17]Àx¦s®æ,
'¥OBrr³o³q¥Î«¬ÅܼƬO ¤Gºû°}¦C,¥HxRÅܼÆÀx¦s®æȱa¤J°}¦C¸Ì
Set xU = [A1]: T = Val(xU)
'¡ô¥OxU³oÀx¦s®æÅܼƬO [A1]Àx¦s®æ,
'¥OT³o³q¥Î«¬ÅܼƬO xUÅܼÆÀx¦s®æÈÂনªº·s¼Æ¦r
For Each A In Brr
'¡ô³]³v¶µ°j°é!¥OA³o³q¥Î«¬ÅܼƬO Brr°}¦C¸Ìªº¤@Ó°}¦CÈ
A = Format(A, "0000")
'¡ô¥OAÅܼƬO ¥|¦ì¼Æªº¼Æ¦r½X¦r¦ê(Y¤£¨¬¥|½X!©ó«e¤è¥H0¸É¨¬)
If A <> vbNullString And Not Z.contains(A) Then Z.Add (A)
'¡ô¦pªGAÅܼƤ£¬O ªø«×¬°¹sªº¦r¦ê,¦Ó¥BAÅܼƤ£¦bZ°}¦C¸Ì?
'¦pªG±ø¥ó¦¨¥ß´N§â AÅܼƯǤJZ°}¦C¸Ì
Next
Z.Sort
'¡ô¥OZ°}¦C°µ¶¶±Æ§Ç
For Each A In Z: Y(Val(A)) = 0: Next
'¡ô³]³v¶µ°j°é!±NZ°}¦C¸ÌªºÈ·íkey,item¬O0,¯Ç¤JY¦r¨å¸Ì
For Each A In xR
'¡ô³]³v¶µ°j°é!¥OAÅܼƬOxRÅܼÆÀx¦s®æ¤¤ªº¤@®æ
If Val(A) = T Then Set xU = Union(xU, A)
'¡ô¦pªGAÅܼÆÈÂন¼ÆÈ«á = TÅܼÆ!´N±NAÅܼƯǤJxUÀx¦s®æ¶°¸Ì
Y(Val(A)) = Y(Val(A)) + 1
'¡ô¥OAÅܼÆÈÂà¼ÆÈ·íkey,item¬O item¦Û¨È+1
Next
xR.Interior.ColorIndex = xlNone: xU.Interior.ColorIndex = 6
'¡ô¥OxRÅܼÆÀx¦s®æ©³¦â³]¬° µL©³¦â:¥OxUÅܼÆÀx¦s®æ©³¦â³]¬° ¶À¦â
[L:M].ClearContents: [L1:M1] = [{"¼Æ¦r", "¥X²{¦¸¼Æ"}]
'¡ô¥O[L:M]Àx¦s®æ²M°£¤º®e:¥O[L1:M1]³o¨â®æ¥H¡ô°}¦C¨â¦r¦ê±a¤J
[L2].Resize(Y.Count, 1) = Application.Transpose(Y.keys)
'¡ô¥O[L2]ÂX®i¦V¤UY¦r¨åkey¼Æ¶q¼ÆªºÀx¦s®æ,
'¥HY¦r¨åkeysÂà¸m«á±a¤JÀx¦s®æ
[M2].Resize(Y.Count, 1) = Application.Transpose(Y.items)
'¡ô¥O[M2]ÂX®i¦V¤UY¦r¨åkey¼Æ¶q¼ÆªºÀx¦s®æ,
'¥HY¦r¨åitemsÂà¸m«á±a¤JÀx¦s®æ
Set Y = Nothing: Set Z = Nothing: Set xR = Nothing
Set xU = Nothing: Erase Brr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub |
|