- ©«¤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
|
¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-3-24 10:25 ½s¿è
¦^´_ 1# mmggmm
ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹¥DÃD½m²ß°}¦C»P¦r¨å,¾Ç²ßVBAªº¸Ñ¨M¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
°õ¦æ«e:
°õ¦æµ²ªG:
Option Explicit
Sub TEST()
Dim Brr, T, Y, Z, A, xR 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 = [A1:F9]: Brr = xR
'¡ô¥OxR³oÀx¦s®æÅܼƬO [A1:F9]Àx¦s®æ,
'¥OBrr³o³q¥Î«¬ÅܼƬO ¤Gºû°}¦C,¥HxRÅܼÆÀx¦s®æȱa¤J°}¦C¸Ì
For Each A In Brr
'¡ô³]³v¶µ°j°é!¥OA³o³q¥Î«¬ÅܼƬO Brr°}¦C¸Ìªº¤@Ó°}¦CÈ
A = Format(A, "yyyy" & "¦~" & "mm")
'¡ô¥OAÅܼƬO ¥|¦ì¼Æªº¼Æ¦r½X¦~ ³s±µ"¦~",¦A³s±µ2½X¤ë¥÷¦¨ªº·s¦r¦ê
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(A) = 0: Next
'¡ô³]³v¶µ°j°é!±NZ°}¦C¸ÌªºÈ·íkey,item¬O0,¯Ç¤JY¦r¨å¸Ì
For Each A In xR
'¡ô³]³v¶µ°j°é!¥OAÅܼƬOxRÅܼÆÀx¦s®æ¤¤ªº¤@®æ
A = Format(A, "yyyy" & "¦~" & "mm")
'¡ô¥OAÅܼƬO ¥|¦ì¼Æªº¼Æ¦r½X¦~ ³s±µ"¦~",¦A³s±µ2½X¤ë¥÷¦¨ªº·s¦r¦ê
Y(A) = Y(A) + 1
'¡ô¥OAÅܼÆÈÂà¼ÆÈ·íkey,item¬O item¦Û¨È+1
Next
[L:M].ClearContents: [L1:M1] = [{"¤ë¥÷", "¤Ñ¼Æ"}]
'¡ô¥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
Erase Brr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub |
|