ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

EXCEL°ê©w°²¤é¦Û°Ê§ó·s

EXCEL°ê©w°²¤é¦Û°Ê§ó·s

½Ð°Ý¦U¦ì¤j«e½ú
¥Ø«e¤p§Ì¦³°µ£¸¨Ç¸U¦~¾ä©Î¬O±M®×ªºÀÉ®×
¥Ø«e°ê©w°²¤é©Î¸É¯Z¤éªº¤é´Á³£¬O¦b¤À­¶¤W¥Î¤â°Êªº¤è¦¡¥´¤W

½Ð°Ý¦³¨S¦³¤°»ò¤è¦¡¥i¥HÅý¨C¦~ªº°ê©w°²¤é¤Î¸É¯Z¤é¥i¥H¦Û°Ê§ì¨ú¸ê®Æ©O¡H
§Ú¦Û¤v·Q¨ì¥i¯àªº¤è¦¡¦p¹³ªÑ²¼¨º¼Ë¥Îºô­¶§ì¨ú¸ê®Æªº¤è¦¡
¦ýÁÙ¤£½T©w¥i¦æ©Ê

¦A³Â·Ð¦U¦ì¤j¤jÀ°¦£¡A·PÁ¡I

¦^´_ 12# Andy2483

ÁÂÁ«e½úªº¸Ô²Ó¸Ñ»¡
Åý«á¾Ç§Ú¥i¥H³v¤@¤F¸Ñ
·PÁ¡I

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-8 10:20 ½s¿è

¦^´_ 11# ¬PªÅÉ@¦ÐÁl


    ÁÂÁ«e½ú¦A¦^´_
¤À¨É«p¾Ç(«pÁy¥Ö¾Ç¥Í)ªº¤ß±o
¤ß±oµù¸Ñªº¹Lµ{¦A¦¸Àˬd¨ì«Ü¦h¯Êº|!
©ú¦~§À¦æ¬F°|µo¥¬ªº2024¦~¦æ¨Æ¾ä®æ¦¡¦pªG¨SÅÜ??À³¸Ó¥i¥HÄò¥Î

¬¡¤Æ¸£²Ó­M,¦ÒÅç¦Û¤v«í¤ß­@¤ßªº³Ì¨Î¿ï¾Ü ³Â»¶®a±Ú°Q½×ª©ª©
ÁÂÁ½׾Â

Option Explicit
Sub ¤W¯Z¤é_°²¤é_¸É¯Z¤é()
Dim Brr, Sh1, V, xA, xR, Z, P, W
'¡ô«Å§i³o¨ÇÅܼƬO³q¥Î«¬ÅܼÆ
Dim i&, n&, T&
'¡ô«Å§i³o¨ÇÅܼƬOªø¾ã¼Æ
Dim X&(4), Ch$, y%, ymd As Date
'¡ô«Å§iX¬O¤@ºû°}¦C(0~4),(Ch)¬O¦r¦êÅܼÆ,(y)¬Oµu¾ã¼ÆÅܼÆ,(ymd)¬O¤é´ÁÅܼÆ
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
'¡ô¥OW.Z.P¦U¬O¦r¨å
Set Sh1 = Sheets("Sheet1")
'¡ô¥OSh1 ¬O"Sheet1" ¤u§@ªí(ªí¤@)
Set Brr = Range(Sh1.[A1], Sh1.UsedRange)
'¡ô¥OBrr¬Oªí¤@[A1]¨ì ªí¤@¦³¨Ï¥ÎÀx¦s®æ¤§¶¡ ÂX®i¬°³Ì¤p¤è¥¿½d³òªºÀx¦s®æ¶°
Sh1.[AA:AH].ClearContents
'¡ô¥OÄæ¦ì²M°£Àx¦s®æ¤º®e
V = Split(",¤@,¤G,¤T,¥|,¤­,¤»,¤C,¤K,¤E,¤Q,¤Q¤@,¤Q¤G", ",")
'¡ô¥OV¬O Âù¤Þ¸¹¸Ìªº¦r¦ê¥H ","²Å¸¹¤À³Î¦¨ªº¤@ºû¦r¦ê°}¦C(PS:²Ä¤@­Ó¬O"",¯Á¤Þ¸¹¬O0)
For i = 1 To 12
'¡ô³]¶¶°j°é!i±q1¨ì12
   Z(V(i) & "¤ë") = i
   '¡ô¥OV¤@ºû°}¦Cªº°j°é¯Á¤Þ¸¹¦ì¸mªº¦r¦ê¬°key,item¬O°j°é¼Æ,­Ë¶i¦r¨å¸Ì
Next
For Each xR In Brr
'¡ô³]¶¶°j°é!¥OxR¬O BrrÀx¦s®æ¶°¸Ìªº¤@®æ!¥Ñ¥ª¦Ü¥k/¤W¦Ü¤U¶]
   If xR Like "*¦è¤¸####¦~*" Then y = Mid(xR, InStr(xR, "¦è¤¸") + 2, 4)
   '¡ô¦pªGxRªº­È ¸Ì­±ªº¦r¤¸²Õ¦X¦³¥]§t "¦è¤¸" ³s±µ4­Ó¼Æ¦r ¦A³s±µ"¦~" ??
   '±ø¥ó¦¨¥ß!¥Oy¬O ¨úxR­Èªº "¦è¤¸"¦r¤¸¦ì¸m+2 ¶}©l,¨ú4­Ó¦r¤¸ªº­È  PS:2023
   Ch = xR & xR.Item(, 2) & xR.Item(, 3)
   '¡ô¥OCh¦r¦êÅܼƬO xRªº­È³s±µ ¥kÃä®æªº­È,¦A³s±µ¥k2®æªº­È
   If Z.Exists(Ch) And xR.Item(, 3) <> "" Then
   '¡ô¦pªG¥HCh¦r¦êÅܼƬd¹îZ¦r¨å¬O¦³³okey,¦Ó¥BxR ¥k2®æªº­È¤£¬OªÅ¦r¤¸ ??
      Set W(Ch) = xR.Item(1, -1).Resize(14, 7)
      '¡ô¥O¥OCh¦r¦êÅܼƷíkey,ITEM¬OxRÀx¦s®æ¥ª2Àx¦s®æ¶}©l,
      'ÂX®iÁa¦V¦V¤U14¦C(§t¦Û¨­),¾î¦V7Äæ(§t¦Û¨­)ªºÀx¦s®æ½d³ò
      'PS:item¥i¥H¬OÀx¦s®æ¶°!

   End If
Next
Z.Add "«D©P¥ð¤G¤é°²¤é", 1
'¡ô¥O"«D©P¥ð¤G¤é°²¤é"¦r¦ê·íkey,item¬O¼Æ¦r 1,­Ë¤JZ¦r¨å¸Ì
Z.Add "©P¥ð¤G¤é", 3
'¡ô¥O"©P¥ð¤G¤é"¦r¦ê·íkey,item¬O¼Æ¦r 3,­Ë¤JZ¦r¨å¸Ì
Z.Add "¤W¯Z¤é", 5
'¡ô¥O"¤W¯Z¤é"¦r¦ê·íkey,item¬O¼Æ¦r 5,­Ë¤JZ¦r¨å¸Ì
Z.Add "¸É¯Z¤é", 7
'¡ô¥O"¸É¯Z¤é"¦r¦ê·íkey,item¬O¼Æ¦r 7,­Ë¤JZ¦r¨å¸Ì
For Each xR In W.KEYS
'¡ô³]¥~¶¶°j°é!¥OxR¬O W¦r¨å¸Ìkeysªº¤@Áä!¥Ñ«e¨ì«á¶]
   For Each xA In W(xR)
   '¡ô³]¤º¶¶°j°é!¥OxA¬O ¥HxR¦r¦ê¬d¹îW¦r¨å±o¨ìªºitemÀx¦s®æ¶°ªº¤@®æ,
   '¥Ñ¥ª¦Ü¥k/¤W¦Ü¤U¶]

      If IsNumeric(xA) And xA <> "" Then
      '¡ô¦pªG¥ÎIsNumeric()¨ç¼ÆÀˬdxAÀx¦s®æ­È¬O¼Æ¦r,¦Ó¥BxAÀx¦s®æ­È¤£¬OªÅ¦r¤¸ ??
         ymd = y & "/" & Z(xR) & "/" & xA
         '¡ô¥Oymd¤é´ÁÅܼƬO y³s±µ "/"²Å¸¹ ³s±µ¥HxR¦r¦ê¬d¹îZ¦r¨å±o¨ìªºitem­È,
         '¦A³s±µ "/"²Å¸¹,Ä~Äò±µxAÀx¦s®æ­È ¦r¦ê¤§«á,Åܦ¨¤é´Á

         If xA.Interior.ColorIndex <> -4142 Then
         '¡ô¦pªGxAÀx¦s®æ©³¦â¤£¬O µL©³¦â ??
            If Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
            '¡ô¦A¦pªGymd³o¤é´Á¦pªG¬O¬P´Á¤@¨ì¬P´Á¤­¤§¶¡ªº¤é¤l ??
               P(ymd) = "«D©P¥ð¤G¤é°²¤é"
               '¡ôÂùIf±ø¥ó³£¦¨¥ß!´N¥H³oymd¤é´Á·íkey,item¬O "«D©P¥ð¤G¤é°²¤é"¦r¦ê,
               '­Ë¤JP¦r¨å

               X(1) = X(1) + 1
               '¡ô¥OX°}¦C²Ä¤G­Ó­È +1  PS:(¯Á¤Þ¸¹¬O1)
               W(ymd) = X(1)
               '¡ô¥O¥Hymd¤é´Á·íkey,item¬O X°}¦C²Ä¤G­Ó­È  PS:X°}¦C²Ä¤@­Ó­È¬O ""
               Else
               '¡ô¥H¤U §_«h ªºªº³¯­z
                  P(ymd) = "©P¥ð¤G¤é"
                  '¡ô¥O¥H³oymd¤é´Á·íkey,item¬O "©P¥ð¤G¤é"¦r¦ê,­Ë¤JP¦r¨å
                  X(2) = X(2) + 1
                  '¡ô¥OX°}¦C²Ä¤T­Ó­È +1  PS:(¯Á¤Þ¸¹¬O2)
                  W(ymd) = X(2)
                  '¡ô¥O¥Hymd¤é´Á·íkey,item¬O X°}¦C²Ä¤T­Ó­È
            End If
            ElseIf Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
            '¡ô¦pªGxAÀx¦s®æ©³¦â¬O µL©³¦â! ¦A½T©wymd³o¤é´Á¦pªG¬O¬P´Á¤@¨ì¬P´Á¤­¤§¶¡ªº¤é¤l ??
               P(ymd) = "¤W¯Z¤é"
               '¡ô¥O¥H³oymd¤é´Á·íkey,item¬O "¤W¯Z¤é"¦r¦ê,­Ë¤JP¦r¨å
               X(3) = X(3) + 1
               '¡ô¥OX°}¦C²Ä¥|­Ó­È +1  PS:(¯Á¤Þ¸¹¬O3)
               W(ymd) = X(3)
               '¡ô¥O¥Hymd¤é´Á·íkey,item¬O X°}¦C²Ä¥|­Ó­È
               n = n + 1
               '¡ô¥On²Ö¥[ 1  PS:³o¬O­nºâBrr°}¦C«Å§iÁa¦V½d³òªº¼Æ¶q
            Else
            '¡ô¦pªGxAÀx¦s®æ©³¦â¬O µL©³¦â! ¦A½T©wymd³o¤é´Á¦pªG¤£¬O¬P´Á¤@¨ì¬P´Á¤­¤§¶¡ªº¤é¤l ??
               P(ymd) = "¸É¯Z¤é"
               '¡ô¥O¥H³oymd¤é´Á·íkey,item¬O "¸É¯Z¤é"¦r¦ê,­Ë¤JP¦r¨å
               X(4) = X(4) + 1
               '¡ô¥OX°}¦C²Ä¤­­Ó­È +1  PS:(¯Á¤Þ¸¹¬O4)
               W(ymd) = X(4)
               '¡ô¥O¥Hymd¤é´Á·íkey,item¬O X°}¦C²Ä¤­­Ó­È
         End If
      End If
   Next
Next
For ymd = y & "/1/1" To y & "/12/31"
'¡ô³]¤é´Á¶¶°j°é!±q¦~ªì¶]¨ì¦~§À
   If P.Exists(ymd) = Empty Then
   '¡ô¦pªG¥H°j°é¤é´Á¬d¹îP¦r¨å,¬O¨S¦³³o­ÓÁä PS:Empty¬Oªì©l­È
      MsgBox "¯Ê¤Ö: " & ymd
      '¡ô¸õ¥X "¯Ê¤Ö: " ³s±µ°j°é¤é´Á¦r¦êªº´£¥Üµ¡
      GoTo 111
      '¡ô«ö¤F½T»{«á´N¸õ¨ì 111ªº¦ì¸mÄ~Äò°õ¦æ  PS:¯Ê¤é´Á´N¤£¶]¤F
   End If
   T = T + 1
   '¡ô¥OT¼Æ¦rÅܼƲ֥[ 1
Next
ReDim Brr(1 To n, 1 To 8)
'¡ô§â­ì¥»¬OÀx¦s®æ¶°ªºBrrÅܨ­!«Å§i¦¨¬°¤Gºû°}¦C,
'Áa¦V±q1¨ìnÅܼƦC,¾î¦V±q1¨ì8Äæ

For Each xR In P.KEYS
'¡ô³]¶¶°j°é!¥OxR¬O P¦r¨å¸Ìkeysªº¤@Áä!¥Ñ«e¨ì«á¶]
   ymd = xR
   '¡ô¥Oymd¤é´ÁÅܼƸËxRªº­È  PS:¦pªG¨S°O¿ùªº¸Ü!P¦r¨åÀ³¸Ó¬O¸Ë ¦~ªì¨ì¦~§Àªº¤é´ÁÁä,¤é§Oitem
   Brr(W(ymd), Z(P(ymd))) = ymd
   '¡ô¥O(ymd¬d¹îW¦r¨å±o¨ìªºitem­È)¬°¦C¸¹,(ymd¬d¹îZ¦r¨å±o¨ìªºitem­È)¬°Ä渹ªºBrr°}¦C­È¬O ymd¤é´Á
   Brr(W(ymd), Z(P(ymd)) + 1) = Format(ymd, "aaaa")
   '¡ô¥O¥kÃä¾F©~Brr°}¦C­È¬O°ê¦r¬P´Á¼Æ
Next
Sh1.[AA1].Resize(1, 8) = [{"«D©P¥ð¤G¤é°²¤é","","©P¥ð¤G¤é","","¤W¯Z¤é","","¸É¯Z¤é",""}]
'¡ô¥Oªí¤@[AA1]¦V¤UÂX®i1¦C(¦Û¨­¦C),¦V¥kÂX®i8Ä檺Àx¦s®æ,¥H¤@ºû°}¦C­È­Ë¶i¥h
Sh1.[AA2].Resize(n, 8) = Brr
'¡ô¥Oªí¤@[AA2]¦V¤UÂX®in¦C(§t¦Û¨­¦C),¦V¥kÂX®i8Ä檺Àx¦s®æ,¥HBrr°}¦C­È­Ë¶i¥h
Sh1.[AA:AH].Columns.AutoFit
'¡ô¥Oªí¤@[AA:AH]Äæ¼e¦Û°Ê½Õ¾ã
Sh1.[AA1].CurrentRegion.Borders.LineStyle = 1
'¡ô¥Oªí¤@[AA1]Àx¦s®æ¤K¤è¬Û¾F±µÀsªºÀx¦s®æÂX®iªº³Ì¤p¤è¥¿½d³òÀx¦s®æ,ªº®æ½u¬O²Ó¹ê½u
MsgBox y & "¦~ ¦@¦³ " & T & " ¤Ñ" & vbLf & _
       "«D©P¥ð¤G¤é°²¤é ¦@: " & X(1) & " ¤Ñ" & vbLf & _
       "©P¥ð¤G¤é ¦@: " & X(2) & " ¤Ñ" & vbLf & _
       "¤W¯Z¤é ¦@: " & X(3) & " ¤Ñ" & vbLf & _
       "¸É¯Z¤é ¦@: " & X(4) & " ¤Ñ"
'¡ô¸õ¥X´£¥Üµ¡!Åã¥Ü¦U¤é§O²Î­p¤Ñ¼Æ

111
Set W = Nothing: Set Z = Nothing: Set P = Nothing: Set Brr = Nothing
Erase V, X
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 9# Andy2483

¦nªº¡A¤F¸Ñ¡C
·PÁ«e½ú«ä·Q©P¨ì¡I
  :D

TOP

¦^´_ 8# Andy2483

·PÁÂAndy2483«e½úªº¦^ÂÐ
¤F¸Ñ
§Ú¥D­n¤]¬O·Q¤F¸Ñ¥Hºô­¶§ó·sVBA³o³¡¤À¡C
ÁÙ¬O«D±`·PÁ±zªº¸Ñµª¡I

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-7 14:37 ½s¿è

¦^´_ 7# ¬PªÅÉ@¦ÐÁl


    °£¤F¼W¥[Åã¥Ü¤Ñ¼Æ¥H¥~,°õ¦æªºµ²ªG¨S¦³¤£¦P,²³æÀˬd¸ê®Æªí¦]½s¿è¦Óº|±¼ªº¤é´Á
±K¨¾Ãø!¨Ï¥ÎªÌÂÔ·V¬°¤§!

TOP

¦^´_ 6# ¬PªÅÉ@¦ÐÁl


    ÁÂÁ«e½ú¦^´_
1.«e½ú­n¦æ¬F°|ªº¦æ¨Æ¾ä!¬d¦æ¬F°|¤H¨ÆÁ`³B©xºô¥u¬d¨ìªþ¥ó©Î¦æ¨Æ¾ä¹Ï¤ù!¨S¬d¨ì¥Hºô­¶¤å¦r§e²{ªº¦æ¨Æ¾ä,µ¥¬Ý«e½ú­Ìªº¨ä¥L¤è®×
2.³o§ó·s¦æ¨Æ¾äªº§@·~,¤@¦~§ó·s¤@¦¸,¦³¤°»ò¯S§Oªº»Ý­n¶Ü?»Ý­n¨C¤Ñ³£¦AÀˬd¤@¦¸?
3.¦pªG¦³ºô­¶¬O¥H¤å¦rªí®æ§e²{ªº¦æ¨Æ¾ä,À³¸Ó¦³¾÷·|²Å¦X«e½úªº»Ý¨D
4.«á¾Ç¤]·Q¥Hºô­¶§ó·sªº VBA ª¾ÃÑ

TOP

¦^´_ 5# Andy2483

·PÁÂAndy2483«e½úªº¦^ÂÐ
½Ð°Ý¦¹¶K¤å»P¤W¤@½g
°£¤F¼W¥[Åã¥Ü¤Ñ¼Æ¥H¥~
ÁÙ¦³·s¼W©Î­×§ï¤°»ò¤º®e¶Ü¡H

TOP

¦^´_ 4# Andy2483

·PÁÂAndy2483«e½úªº¦^ÂÐ
´ú¸Õ§¹¦¨¥i¥H¥¿±`¨Ï¥Î¡AÁÂÁ¡C

¥t¥~·Q½Ð°Ý¥i¥H¦Û°Ê§ì¨úºô­¶Àɮ׶Ü?
ÁÙ¬O£¸©w­n¤â°Ê¦Û¤v¤U¸ü©O?

TOP

²K¥[²³æ¨¾¿ù:


Option Explicit
Sub ¤W¯Z¤é_°²¤é_¸É¯Z¤é()
Dim Brr, Sh1, V, xA, xR, Z, P, W, i&, n&, Ch$, y%, ymd As Date
Dim X&(4), T&
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set Brr = Range(Sh1.[A1], Sh1.UsedRange)
Sh1.[AA:AH].ClearContents
V = Split(",¤@,¤G,¤T,¥|,¤­,¤»,¤C,¤K,¤E,¤Q,¤Q¤@,¤Q¤G", ",")
For i = 1 To 12
   Z(V(i) & "¤ë") = i
Next
For Each xR In Brr
   If xR Like "*¦è¤¸####¦~*" Then y = Mid(xR, InStr(xR, "¦è¤¸") + 2, 4)
   Ch = xR & xR.Item(, 2) & xR.Item(, 3)
   If Z.Exists(Ch) And xR.Item(, 3) <> "" Then
      Set W(Ch) = xR.Item(1, -1).Resize(14, 7)
   End If
Next
Z.Add "«D©P¥ð¤G¤é°²¤é", 1
Z.Add "©P¥ð¤G¤é", 3
Z.Add "¤W¯Z¤é", 5
Z.Add "¸É¯Z¤é", 7
For Each xR In W.KEYS
   For Each xA In W(xR)
      If IsNumeric(xA) And xA <> "" Then
         ymd = y & "/" & Z(xR) & "/" & xA
         If xA.Interior.ColorIndex <> -4142 Then
            If Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
               P(ymd) = "«D©P¥ð¤G¤é°²¤é"
               X(1) = X(1) + 1
               W(ymd) = X(1)
               Else
                  P(ymd) = "©P¥ð¤G¤é"
                  X(2) = X(2) + 1
                  W(ymd) = X(2)
            End If
            ElseIf Format(ymd, "w") > 1 And Format(ymd, "w") < 7 Then
               P(ymd) = "¤W¯Z¤é"
               X(3) = X(3) + 1
               W(ymd) = X(3)
               n = n + 1
            Else
               P(ymd) = "¸É¯Z¤é"
               X(4) = X(4) + 1
               W(ymd) = X(4)
         End If
      End If
   Next
Next
For ymd = y & "/1/1" To y & "/12/31"
   If P.Exists(ymd) = Empty Then
      MsgBox "¯Ê¤Ö: " & ymd
      GoTo 111
   End If
   T = T + 1
Next

ReDim Brr(1 To n, 1 To 8)
For Each xR In P.KEYS
   ymd = xR
   Brr(W(ymd), Z(P(ymd))) = ymd
   Brr(W(ymd), Z(P(ymd)) + 1) = Format(ymd, "aaaa")
Next
[AA1].Resize(1, 8) = [{"«D©P¥ð¤G¤é°²¤é","","©P¥ð¤G¤é","","¤W¯Z¤é","","¸É¯Z¤é",""}]
[AA2].Resize(n, 8) = Brr
Sh1.[AA:AH].Columns.AutoFit
[AA1].CurrentRegion.Borders.LineStyle = 1
MsgBox y & "¦~ ¦@¦³ " & T & " ¤Ñ" & vbLf & _
       "«D©P¥ð¤G¤é°²¤é ¦@: " & X(1) & " ¤Ñ" & vbLf & _
       "©P¥ð¤G¤é ¦@: " & X(2) & " ¤Ñ" & vbLf & _
       "¤W¯Z¤é ¦@: " & X(3) & " ¤Ñ" & vbLf & _
       "¸É¯Z¤é ¦@: " & X(4) & " ¤Ñ"


111
Set W = Nothing: Set Z = Nothing: Set P = Nothing: Set Brr = Nothing
Erase V, X
End Sub

TOP

        ÀR«ä¦Û¦b : ¤f»¡¤@¥y¦n¸Ü¡A¦p¤f¥X½¬ªá¡F¤f»¡¤@¥yÃa¸Ü¦p¤f¦R¬r³D¡C
ªð¦^¦Cªí ¤W¤@¥DÃD