Andy2483

¦^´_ 1# PJChen


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾Ç¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, i&, j&, R, T, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("¸ËÂd³qª¾")
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
If Not R Is Nothing Then R = R.Row
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
For i = 1 To UBound(Brr)
   If Brr(i, 1) = "" Then
      For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
      If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
   End If
   Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
   If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
Set MyBook = ThisWorkbook
MyPath = MyBook.Path & "\"
If Dir(MyPath & Td, vbDirectory) = "" Then MkDir MyPath & Td
For Each T In Y.KEYS
   If InStr(T, "|") Then GoTo i02
   Sheets("¸ËÂd³qª¾").Copy
   Set xU = Cells(Rows.Count, 1).Resize(1, 8)
   For i = 1 To UBound(Brr)
      If Brr(i, 1) <> T Then
         Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
      End If
   Next
   xU.Delete: [A7] = 1
   Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
   ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   ActiveWindow.Close
i02: Next
[A7].Resize(UBound(Brr), 8) = Brr
Set Y = Nothing: Set Sh = Nothing: Erase Brr
End Sub

Andy2483

¦^´_ 3# PJChen


    ÁÂÁ«e½ú¦^´_
«á¾Ç¥H#1¼Óªº½d¨Ò´Ó¤Jµ{¦¡½X°õ¦æ«á¤£·|²£¥Í#3¼ÓªºÀÉ®×,½Ð«e½ú¦A¸Õ¸Õ¬Ý©Î¤W¶Ç´Ó¤Jµ{¦¡ªº·s­ìÀÉ

Andy2483

¦^´_ 5# PJChen


    ÁÂÁ«e½ú¦^´_,ÁÂÁ½׾Â
1.¬õ®Ø³BAÄ檺§Ç¸¹¤£¬O¦C§Ç,¦Ó¬O¶µ¥Ø§Ç,©Ò¥H»Ý­n­n¨D«e¤@­Ó¬yµ{key inªÌ­n¦Û«ß
1.1.¤£¸Ó¶ñ¼Æ¦rªº´NªÅ®æ
1.2.¸Ó¶ñ¤Jªº¥¿½T¼Æ¦r­nºë½T¿é¤J

2.«á¤èºñ®Ø³B°Ï°ìªºªÅ¦C¦³¨âºØ¤è¦¡
2.1.key inªÌ­n¦Û«ß§R°£³o¨ÇªÅ¦C
2.2.½Ð«e½ú¥H¤U³sµ²½Ð¬ã¨s¤@¤U,À³¥Î.EntireRow§â¤£­nªº¦C§R°£
https://learn.microsoft.com/zh-t ... loop-to-delete-cell

3.Q:¸ê®Æ°Ï¤º,¦³³]©w¦Û°Ê´«¦æ,¦ý¥t¦s·sÀÉ«á,­ì¥»½Õ¾ã¦nªº¦C°ª,·|¦Û°ÊÁY´î
A:3.1.³o¬O§R°£§½³¡Àx¦s®æ,«á¤èÀx¦s®æ©¹¤W²¾°Ê,²¾°Ê«á»Ý­n°t¦X·í¦C¦C°ª
A:3.2.²³æªº¤è¦¡:¤]¬O¾ã¦C§R°£,½Ð«e½ú¸Õ¸Õ§ï¬Ý

¯¬ ¦¨¥\

¤U¸ü (132.84 KB)

2023-4-27 07:50

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾Ç¤µ¤Ñ½Æ²ß#2¼Óªº¾Ç²ß¤è®×,¤è®×¤ß±oµù¸Ñ¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

Option Explicit
Sub TEST()
Dim Brr, Crr, V, Y, R, T, i&, j&, Td$, Tn$, G1$
Dim xR As Range, xU As Range, Sh As Worksheet, MyBook, MyPath
'¡ô«Å§iÅܼÆ:(Brr,Crr,V,Y,R,T)¬O³q¥Î«¬ÅܼÆ,(i,j)¬Oªø¾ã¼Æ,(Td,Tn,G1)¬O¦r¦êÅܼÆ
',(xR,xU)¬OÀx¦s®æÅܼÆ,Sh¬O¤u§@ªíÅܼÆ,(MyBook,MyPath)¬O³q¥Î«¬ÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OY³o³q¥Î«¬ÅܼƬO ¦r¨å
Set Sh = Sheets("¸ËÂd³qª¾")
'¡ô¥OSh³oÀx¦s®æÅܼƬO ¦W¬°"¸ËÂd³qª¾"ªº¤u§@ªí
Set R = Sh.[D:D].Find("TOTAL", Lookat:=xlWhole)
'¡ô¥OR³o³q¥Î«¬ÅܼƬO ¥HRange.Find¤èªk§äDÄ椤Àx¦s®æ­È¬O¥þ¦P "TOTAL"¦r¦ê
'https://learn.microsoft.com/zh-tw/office/vba/api/excel.range.find
If Not R Is Nothing Then R = R.Row Else Exit Sub
'¡ô¦pªGRÅܼƧä¨ìÀx¦s®æ!´N¥OR³oÅܼƴ«¸ËRÅܼÆ(Àx¦s®æ)ªº¦C¸¹,
'§_«h´Nµ²§ôµ{¦¡°õ¦æ
Brr = Range(Sh.[A7], Sh.Cells(R - 1, "H"))
'¡ô¥OBrr³o³q¥Î«¬ÅܼƬO ¤Gºû°}¦C,¥H[A7]¨ìHÄæ(RÅܼÆ-1)¦CÀx¦s®æ­È±a¤J
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é!i±q1¨ì Brr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
   If Brr(i, 1) = "" Then
   '¡ô¦pªGi°j°é¦C²Ä1ÄæBrr°}¦C­È¬O ªÅ¦r¤¸
      For j = 1 To 8: T = T & Trim(Brr(i, j)): Next
      '¡ô³]¶¶°j°é!j±q1¨ì 8,¥OT³o¦r¦êÅܼƬO¦Û¨­³s±µ,
      '(i°j°é¦Cj°j°éÄæBrr°}¦C­È)¥h°£ÀY§ÀªÅ¥Õ¦r¤¸«á²Õ¦¨ªº·s¦r¦ê
      If T <> "" Then Brr(i, 1) = Brr(i - 1, 1) Else: GoTo i01
      '¡ô¦pªGTÅܼƤ£¬OªÅ¦r¤¸!´N¥Oi°j°é¦C²Ä1ÄæBrr°}¦C­È¬O¤W¤@¦C°}¦C­È
      '§_«h´N¸õ¨ìi01¼Ð¥Ü¦ì¸mÄ~Äò°õ¦æ
   End If
   Y(Brr(i, 1)) = Y(Brr(i, 1)) + 1
   '¡ô¥Oi°j°é¦C²Ä1ÄæBrr°}¦C­È·íkey,item¬Oitem¦Û¨­²Ö¥[1
   If Y(Brr(i, 1) & "|c") = "" Then Y(Brr(i, 1) & "|c") = Brr(i, 3)
   '¡ô¦pªG¥Oi°j°é¦C²Ä1ÄæBrr°}¦C­È·íkey¬dY¦r¨å±oitem­È¬O ªÅ¦r¤¸?
   '´N¥O¥Oi°j°é¦C²Ä1ÄæBrr°}¦C­È³s±µ "|c"«áªº·s¦r¦ê·íkey,item¬Oi°j°é¦C²Ä3ÄæBrr°}¦C­È
i01: T = "": Next
If Y.Count = 0 Then Exit Sub
'¡ô¦pªGY¦r¨åkeyªº­Ó¼Æ¬O 0­Ó!´Nµ²§ôµ{¦¡°õ¦æ
G1 = Sh.[G1].Text & Sh.[E1] & "-" & Replace(Replace(Sh.[G2], "/", ""), "#", "") & Sh.[H2]
'¡ô¥OG1³o¦r¦êÅܼƬO [G1]Àx¦s®æÅé²{ªº¦rÂন¤å¦r ³s±µ[E1]Àx¦s®æ­È,³s±µ"-",
'¦A³s±µ([G2]Àx¦s®æ¥h°£"/"¦r¤¸»P"#"¦r¤¸),³Ì«á³s±µ[H2]Àx¦s®æ­È
Td = Format(Now, "YYYY_MM_DD_HH_MM_SS")
'¡ô¥OTd³o¦r¦êÅܼƬO ²{¦b®É¶¡Âন¤å¦r
Set MyBook = ThisWorkbook
'¡ô¥OMyBook³o³q¥Î«¬ÅܼƬO ¥»¬¡­¶Ã¯
MyPath = MyBook.Path & "\"
'¡ô¥OMyPath³o³q¥Î«¬ÅܼƬO ¥»¬¡­¶Ã¯¸ô®| ³s±µ"\"«áªº·s¦r¦ê
MkDir MyPath & Td
'¡ô¥O²£¥Í¤@­Ó¸ê®Æ§¨,¦W¦r¬O TD,¸ô®|¦bMyPath
For Each T In Y.KEYS
'¡ô³]³v¶µ°j°é!¥OTÅܼƬO Y¦r¨å¸Ìªº¤@­Ókey
   If InStr(T, "|") Then GoTo i02
   '¡ô¦pªGTÅܼƸ̦³¥]§t"|"¦r¤¸!´N¸õ¨ìi02¼Ð¥Ü¦ì¸mÄ~Äò°õ¦æ
   Sh.Copy
   '¡ô¥OShÅܼÆ("¸ËÂd³qª¾"¤u§@ªí)½Æ»s¨ì·s¶}ªº¬¡­¶Ã¯
   Set xU = Cells(Rows.Count, 1).Resize(1, 8)
   '¡ô¥OxU³oÀx¦s®æÅܼƬO¥»ªíAÄæ³Ì«á¦CÀx¦s®æ,¦V¥kÂX®i8®æ½d³òªºÀx¦s®æ
   For i = 1 To UBound(Brr)
   '¡ô¥O³]¶¶°j°é!i±q1¨ì Brr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
      If Brr(i, 1) <> T Then
      '¡ô¦pªGi°j°é¦C²Ä1ÄæBrr°}¦C­È »P ÅܼƤ£¦P?
         Set xU = Union(Cells(i + 6, 1).Resize(1, 8), xU)
         '¡ô¥OxUÅܼÆÄ~Äò¥HUnion()¤èªk¯Ç¤J¤£­nªºÀx¦s®æ
      End If
   Next
   xU.Delete: [A7] = 1
   '¡ô¥OxUÅܼÆ(Àx¦s®æ)§R°£,¥O[A7]Àx¦s®æ­È¬O 1
   Tn = Y(T & "|c") & "-" & G1 & ".xlsx"
   '¡ô¥OTn³o¦r¦êÅÜ¼Æ ¬O²Õ¦X¦U¥²­nÅܼƲզ¨ªº·s¦r¦ê
   ActiveWorkbook.SaveAs Filename:=MyPath & Td & "\" & Tn, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   '¡ô¥OÀÉ®×¨Ì «ü©w¦ì¸m «ü©wÀɦW Àx¦s
   ActiveWindow.Close
   '¡ôÃö³¬ÀÉ®×
i02: Next
Set Y = Nothing: Set Sh = Nothing: Erase Brr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub