Andy2483

¦^´_ 3# shuo1125


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹¥DÃD½m²ß°}¦C»P¦r¨åªº¸Ñ¨M¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Dim Brr, A, Y, Z, Yk, T$, T2$, T3$, T9$, T10$, S1$, S2$
Dim x%, C%, N&, i&, P&, B(3), Crr(1 To 1000, 1 To 20)
Set Y = CreateObject("Scripting.Dictionary")
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
For i = 2 To UBound(Brr)
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   A = Y(S1)
   If Not IsArray(A) Then A = Crr
   T9 = Brr(i, 9)
   B(1) = Mid(T9, 1, 3): B(2) = Mid(T9, 4, 2): B(3) = Mid(T9, 6, 2)
   B(0) = B(1) & "." & B(2) & "." & B(3) & "#" & Val(Mid(T9, 8))
   T10 = Brr(i, 10)
   If T10 Like "¨R*" = False Then
      N = Y(S1 & "|r")
      N = N + 1
      Y(S1 & "|r") = N
      S2 = B(0) & "-" & T10:  Y(S2) = N
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      For x = 5 To 6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         A(N, x + 14) = A(N, x)
      Next
      Y(S1) = A
      GoTo i01
      ElseIf T10 Like "*¤ë±b´Ú" Then
         B(0) = Mid(Split(T10, "¤ë")(0), 2)
         B(0) = B(0) & Replace(T10, "¨R", ".#0-")
         B(0) = Replace(B(0), "¤ë±b´Ú", "À³¥I±b´ÚÁ`ÃB")
      ElseIf T10 Like "¨R###/*#/*#*" Then
         B(1) = Mid(T10, 2, 4)
         B(2) = Format(Split(Mid(T10, 6), "#")(0), "MM/DD")
         B(3) = "#" & Split(T10, "#")(1)
         B(0) = Replace(B(1) & B(2) & B(3), "/", ".")
      ElseIf T10 Like "¨R?????*  ###/*#/*#" Then
         B(0) = Split(Mid(T10, 3), "  ")
         B(1) = Mid(Brr(i, 11), 1, 3)
         B(2) = "." & Mid(Brr(i, 11), 4) & ".#0-"
         B(3) = B(0)(0) & "  " & B(0)(1)
         B(0) = B(1) & B(2) & B(3)
   End If
   C = Format(Brr(i, 4), "M") + 6
   A(Y(B(0)), C) = Brr(i, 16) + Brr(i, 17)
   A(Y(B(0)), 20) = A(Y(B(0)), 20) - A(Y(B(0)), C)
   P = Brr(i, 14) + Brr(i, 15)
   A(Y(B(0)), 19) = A(Y(B(0)), 19) - P
   Y(S1) = A
   
i01:
Next
'====================================
For Each Yk In Y.keys
   If IsArray(Y(Yk)) Then
      On Error Resume Next
      Sheets(Val(Yk) & "").Delete
      On Error GoTo 0
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      With Sheets(1)
         .Name = Val(Yk)
         .UsedRange.Offset(5, 0).Delete
         With .[A5].Resize(Y(Yk & "|r"), 20)
            .Value = Y(Yk)
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
         End With
         .[C3] = Y(Yk & "/c")
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         N = .Cells(Rows.Count, "F").End(3).Row
         With .Cells(N + 1, "F").Resize(1, 15)
            .Value = "=SUM(F5:F" & N & ")"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A, B
End Sub

Andy2483

¦^´_ 7# shuo1125


    ÁÂÁ«e½ú¦^´_
1.¥¿©Ò¿×·í§½ªÌ°g,¸Ñ½d¨Ò¤~ª¾½d¨Ò°ÝÃD¦b­þ¸Ì
2.«e½ú¦h¼{¤F,¨Ã¨S¦³®ö¶O®É¶¡,«á¾Ç¦b½×¾Â¤W¦b¦¹©«¤W¾Ç²ß¨ì«Ü¦hª¾ÃÑ

3.´N«á¾Çªº»{ª¾»P¸gÅç,³ÆµùÄæÄÝ©óÂø¶µÄæ¦ì,°µ¬°ÃöÁä¦rÄ榳«Ü¦hºÃ¼{,
½Ð«e½ú¬dÃÒ¤@¤UKÄæ³ÆµùÄæ¬O§_³£¥u©ñ ¶Ç²¼½s¸¹-§Ç(¨R¾P¸¹½X)

Andy2483

¦^´_ 7# shuo1125


    ¥HKÄæ³ÆµùÄæ³£¥u©ñ ¶Ç²¼½s¸¹-§Ç(¨R¾P¸¹½X)ªº±¡¹Ò¤U°µ¦r¨å¹ï·Ó¸Ñ¨M¤è®×¦p¤U,
½Ð«e½ú°Ñ¦Ò

KÄæ³ÆµùÄæ(¶Ç²¼½s¸¹-§Ç)¨R¾PHÄæ(¶Ç²¼½s¸¹-§Ç),¤@¹ï¦h¹ï¨R¾P¬O¤°»ò³W«h??

¤U¸ü (104.82 KB)

2023-3-22 08:26

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Dim Brr, A, Y, Z, Yk, T2$, T3$, T8$, T11$, S1$
Dim x%, C%, N&, i&, P&, Crr(1 To 1000, 1 To 20)
Set Y = CreateObject("Scripting.Dictionary")
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
For i = 2 To UBound(Brr)
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   A = Y(S1)
   If Not IsArray(A) Then A = Crr
   T8 = Brr(i, 8): T11 = Brr(i, 11)
   If T11 Like "#####*" = False Then
      N = Y(S1 & "|r")
      N = N + 1
      Y(S1 & "|r") = N
      Y(T8) = N
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      For x = 5 To 6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         A(N, x + 14) = A(N, x)
      Next
      Y(S1) = A
      GoTo i01
   End If
   C = Format(Brr(i, 4), "M") + 6
   A(Y(T11), C) = Brr(i, 16) + Brr(i, 17)
   A(Y(T11), 20) = A(Y(T11), 20) - A(Y(T11), C)
   P = Brr(i, 14) + Brr(i, 15)
   A(Y(T11), 19) = A(Y(T11), 19) - P
   Y(S1) = A
   
i01:
Next
'====================================
For Each Yk In Y.keys
   If IsArray(Y(Yk)) Then
      On Error Resume Next
      Sheets(Val(Yk) & "").Delete
      On Error GoTo 0
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      With Sheets(1)
         .Name = Val(Yk)
         .UsedRange.Offset(5, 0).Delete
         With .[A5].Resize(Y(Yk & "|r"), 20)
            .Value = Y(Yk)
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
         End With
         .[C3] = Y(Yk & "/c")
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         N = .Cells(Rows.Count, "F").End(3).Row
         With .Cells(N + 1, "F").Resize(1, 15)
            .Value = "=SUM(F5:F" & N & ")"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub

Andy2483

¦^´_ 7# shuo1125

1.¬O¥H(¹ô§O + ¶Ç²¼½s¸¹-§Ç)¬üª÷¨R¾P¬üª÷,¥x¹ô¨R¾P¥x¹ô¶Ü?

2.µ²ªGªíªºSÄæ­ì¹ô¾lÃB Á`¦X­p¦³·N¸q¶Ü? «O¯d¦X­p©Î¨ú®ø¦X­p?
PS:­ì¹ô¾lÃB¥i¯à¦³¦hºØ¹ô§Oªº¾lÃB,¬Û¥[³Q¤Þ¥Î³ô¼{

Option Explicit
Sub TEST_¹ô§O_¶Ç²¼½s¸¹§Ç()
Application.DisplayAlerts = False
Dim Brr, A, Y, Z, Yk, T2$, T3$, T8$, T11$, T12$, S1$, S2$
Dim x%, C%, N&, i&, P&, Crr(1 To 1000, 1 To 20)
Set Y = CreateObject("Scripting.Dictionary")
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
For i = 2 To UBound(Brr)
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   A = Y(S1)
   If Not IsArray(A) Then A = Crr
   T8 = Brr(i, 8): T11 = Brr(i, 11): T12 = Brr(i, 12)
   If T11 Like "#####*" = False Then
      N = Y(S1 & "|r"): N = N + 1: Y(S1 & "|r") = N
      S2 = T8 & "|" & T12: Y(S2) = N
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      For x = 5 To 6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         A(N, x + 14) = A(N, x)
      Next
      Y(S1) = A: GoTo i01
   End If
   C = Format(Brr(i, 4), "M") + 6
   S2 = T11 & "|" & T12
   A(Y(S2), C) = Brr(i, 16) + Brr(i, 17)
   A(Y(S2), 20) = A(Y(S2), 20) - A(Y(S2), C)
   P = Brr(i, 14) + Brr(i, 15)
   A(Y(S2), 19) = A(Y(S2), 19) - P
   Y(S1) = A
   
i01:
Next
'====================================
For Each Yk In Y.keys
   If IsArray(Y(Yk)) Then
      On Error Resume Next
      Sheets(Val(Yk) & "").Delete
      On Error GoTo 0
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      With Sheets(1)
         .Name = Val(Yk)
         .UsedRange.Offset(5, 0).Delete
         With .[A5].Resize(Y(Yk & "|r"), 20)
            .Value = Y(Yk)
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
         End With
         .[C3] = Y(Yk & "/c")
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         N = .Cells(Rows.Count, "F").End(3).Row
         With .Cells(N + 1, "F").Resize(1, 15)
            .Value = "=SUM(F5:F" & N & ")"
            If .Item(14) <> .Item(15) Then .Item(14) = "NA"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub

Andy2483

¦^´_ 12# shuo1125


    TÄæ ¨R±b ¹ïÀ³KÄæ(³Æµù)¬OªÅ®æ,¦Ó¤£¬O ¸¹½X(¶Ç²¼½s¸¹-§Ç)¥Nªí¤°»ò·N«ä?

¤U¸ü (218.4 KB)

2023-3-22 10:28

½Ð«e½ú¬dÃÒ¤@¤UKÄæ³ÆµùÄæ¬O§_³£¥u©ñ ¶Ç²¼½s¸¹-§Ç(¨R¾P¸¹½X)
  >¨R¾P®É©ñªºKÄ楲©w¬°¶Ç²¼½s¸¹-§Ç¡C

Andy2483

¦^´_ 14# shuo1125


    ¦]¬°KÄæ°µ¹ïÀ³¥i¯à¤£¨c¾a,»Ý­n§ó¦hÅçÃÒÀˬd
¥H¤U³o°ÝÃD¤]¬O¤â»~?ÁÙ¬O¨t²Î¼´¸ê®Æ´N¿ù?
¥ß±b KÄ榳¸¹½X
ÁÙ¬O¨ä¥L¦]¯À?

¤U¸ü (215.33 KB)

2023-3-22 10:48

Andy2483

¦^´_ 16# shuo1125


    ÁÂÁ«e½ú,½Ð¸Õ¸Õ¬Ý

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Dim Brr, A, Y, Z, Yk, T2$, T3$, T8$, T11$, T12$, T20$, S1$, S2$
Dim x%, C%, N&, i&, P&, Crr(1 To 1000, 1 To 20)
Set Y = CreateObject("Scripting.Dictionary")
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
For i = 2 To UBound(Brr)
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   A = Y(S1)
   If Not IsArray(A) Then A = Crr
   T8 = Brr(i, 8): T11 = Brr(i, 11)
   T12 = Brr(i, 12): T20 = Brr(i, 20)
   If T20 = "¨R±b" Then
      If T11 Like "#####*" = False Then
         Application.Goto Sheets("¸ê®Æ°Ï").Rows(i)
         MsgBox "¨R±b³ÆµùÄ沧±`": Exit Sub
      End If
      If Y.Exists(T11 & "|" & T12) = Empty Then
         Application.Goto Sheets("¸ê®Æ°Ï").Rows(i)
         MsgBox "µLªk¨R±b": Exit Sub
      End If
   End If
   If T20 = "¥ß±b" Then
      N = Y(S1 & "|r"): N = N + 1: Y(S1 & "|r") = N
      S2 = T8 & "|" & T12: Y(S2) = N
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      For x = 5 To 6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         A(N, x + 14) = A(N, x)
      Next
      Y(S1) = A: GoTo i01
   End If
   C = Format(Brr(i, 4), "M") + 6
   S2 = T11 & "|" & T12
   A(Y(S2), C) = Brr(i, 16) + Brr(i, 17)
   A(Y(S2), 20) = A(Y(S2), 20) - A(Y(S2), C)
   P = Brr(i, 14) + Brr(i, 15)
   A(Y(S2), 19) = A(Y(S2), 19) - P
   Y(S1) = A
   
i01:
Next
'====================================
For Each Yk In Y.keys
   If IsArray(Y(Yk)) Then
      On Error Resume Next
      Sheets(Val(Yk) & "").Delete
      On Error GoTo 0
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      With Sheets(1)
         .Name = Val(Yk)
         .UsedRange.Offset(5, 0).Delete
         With .[A5].Resize(Y(Yk & "|r"), 20)
            .Value = Y(Yk)
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
         End With
         .[C3] = Y(Yk & "/c")
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         N = .Cells(Rows.Count, "F").End(3).Row
         With .Cells(N + 1, "F").Resize(1, 15)
            .Value = "=SUM(F5:F" & N & ")"
            If .Item(14) <> .Item(15) Then .Item(14) = "NA"
            '¡ôµ²ªGªíÁ`¾lÃB¦X­p ¦pªGSÄæ<>TÄæ!´NÅýSÄæÅã¥Ü "NA"
            '§_«hSÄæ¦PTÄæ
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub

Andy2483

¦^´_ 18# shuo1125


    ÁÂÁ«e½ú¦A¦^´_
«á¾ÇÂǦ¹¥DÃD¾Ç²ß¨ì«Ü¦hª¾ÃÑ,¾Ç²ß¤ß±oµù¸Ñ¦p¤U,½Ð«e½ú°Ñ¦Ò,½Ð¦U¦ì«e½ú«ü±Ð
¦pªGÁÙ¦³«á¾Ç¥i¥H¾Ç²ßªº!½Ð«e½úÄ~Äò´£¥X

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
'¡ô¥Oµ{§Ç¹J¨ì¬O§_¯uªº­n§R°£ªººÃ°Ý®É,´N¤£­n¦A°Ý¤F!§R¤F¥L!
Dim Brr, A, Y, Z, Yk, T2$, T3$, T8$, T11$, T12$, T20$, S1$, S2$
Dim x%, C%, N&, i&, P&, Crr(1 To 1000, 1 To 20)
'¡ô«Å§iÅܼÆ:(Brr,A,Y,Z,Yk)¬O³q¥Î«¬ÅܼÆ,
'(T2,T3,T8,T11,T20,T12,S1,S2)¬O¦r¦êÅܼÆ,(x,C)¬Oµu¾ã¼ÆÅܼÆ,
'(N,i,P)¬Oªø¾ã¼ÆÅܼÆ,Crr¬O°}¦CÅܼÆ(Áa¦V1¨ì1000,¾î¦V1¨ì20)
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OY³o³q¥Î«¬ÅܼƬO ¦r¨å
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
'¡ô¥OZ³o³q¥Î«¬ÅܼƬO¤@ºû°}¦C(¦@9­Ó°}¦C­È,¯Á¤Þ¸¹0¨ì8)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
'¡ô¥OBrr³o³q¥Î«¬ÅܼƬO¤Gºû°}¦C,¥H¸ê®Æ°Ïªí¦³¨Ï¥ÎÀx¦s®æ­È±a¤J
For i = 2 To UBound(Brr)
'¡ô³]¶¶°j°é!i±q2¨ìBrr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   '¡ô¥OT2³o¦r¦êÅܼƬO i°j°é¦C²Ä2ÄæBrr°}¦C­È,
   '¥OT3³o¦r¦êÅܼƬO i°j°é¦C²Ä3ÄæBrr°}¦C­È
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   '¡ô¥OS1³o¦r¦êÅܼƬO T2ÅÜ¼Æ ³s±µ"|" ¦A³s±µT3Åܼƪº·s¦r¦ê,
   '¥O¥HS1ÅÜ¼Æ ³s±µ"/b"¦¨ªº·s¦r¦ê·íkey,item¬OT2ÅܼÆ,¯Ç¤JY¦r¨å
   '¥O¥HS1ÅÜ¼Æ ³s±µ"/c"¦¨ªº·s¦r¦ê·íkey,item¬OT3ÅܼÆ,¯Ç¤JY¦r¨å
   A = Y(S1)
   '¡ô¥OA³o³q¥Î«¬ÅܼƬO ¥HS1ÅܼƬdY¦r¨å±o¨ìªºitem­È
   If Not IsArray(A) Then A = Crr
  '¡ô¦pªGAÅܼƸg§PÂ_:¤£¬O°}¦C!´N¥OAÅܼƬOCrrÅܼÆ
   T8 = Brr(i, 8): T11 = Brr(i, 11)
   T12 = Brr(i, 12): T20 = Brr(i, 20)
   '¡ô¥OT8³o¦r¦êÅܼƬO i°j°é¦C²Ä8ÄæBrr°}¦C­È,
   '¥OT11³o¦r¦êÅܼƬO i°j°é¦C²Ä11ÄæBrr°}¦C­È,
   '¥OT12³o¦r¦êÅܼƬO i°j°é¦C²Ä12ÄæBrr°}¦C­È
   '¥OT20³o¦r¦êÅܼƬO i°j°é¦C²Ä20ÄæBrr°}¦C­È
   If InStr("/¨R±b/¥ß±b/", "/" & T20 & "/") = 0 Then
   '¡ô¦pªGT20ÅܼƤ£¬O ¨R±b ,¤]¤£¬O ¥ß±b??
      Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
      '¡ô¥OÀx¦s®æ´å¼Ð¸õ¨ìiÅܼƦC
      MsgBox "TÄ椣©ú ¥ß¨R±bÃþ§O": Exit Sub
      '¡ô¸õ¥X´£¥Üµ¡~~~:µ²§ôµ{¦¡°õ¦æ
   End If
   If T20 = "¨R±b" Then
   '¡ô¦pªGT20ÅܼƬO "¨R±b"¦r¦ê ?
      If T11 Like "#####*" = False Then
      '¡ô¦pªGT11ÅܼƤ£¬O¥H5­Ó³sÄò¼Æ¦r¶}ÀYªº¦r¦ê?
         Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
         '¡ô¥OÀx¦s®æ´å¼Ð¸õ¨ìiÅܼƦC
         MsgBox "¨R±b³ÆµùÄ沧±`": Exit Sub
         '¡ô¸õ¥X´£¥Üµ¡~~~:µ²§ôµ{¦¡°õ¦æ
      End If
      If Y.Exists(T11 & "|" & T12) = Empty Then
      '¡ô¦pªG¥HT11ÅÜ¼Æ ³s±µ"|" ¦A³s±µT12Åܼƪº·s¦r¦ê,
      '¬dY¦r¨å¸Ì¨S¦³³okey??
         Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
         '¡ô¥OÀx¦s®æ´å¼Ð¸õ¨ìiÅܼƦC
         MsgBox "µLªk¨R±b": Exit Sub
         '¡ô¸õ¥X´£¥Üµ¡~~~:µ²§ôµ{¦¡°õ¦æ
      End If
   End If
   If T20 = "¥ß±b" Then
   '¡ô¦pªGT20ÅÜ¼Æ "¥ß±b"¦r¦ê
      N = Y(S1 & "|r"): N = N + 1: Y(S1 & "|r") = N
      '¡ô¥ON³oªø¾ã¼ÆÅܼƬO (S1ÅܼƳs±µ"|r"¦¨ªº·s¦r¦ê)¬dY¦r¨åªºitem­È
      '¥ONÅܼƲ֥[1,
      '¥O(S1ÅܼƳs±µ"|r"¦¨ªº·s¦r¦ê)ªºitem­È¬O NÅܼÆ
      S2 = T8 & "|" & T12: Y(S2) = N
      '¡ô¥OS2³o¦r¦êÅܼƬO T8ÅÜ¼Æ ³s±µ"|" ¦A³s±µT12Åܼƪº·s¦r¦ê,
      '¡ô¥O¥HS2ÅܼƷíkey,item¬ONÅܼÆ,¯Ç¤JY¦r¨å¸Ì
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      '¡ô³]¶¶°j°é!x±q1¨ì4,¥ONÅܼƦC²ÄxÅܼÆÄæA°}¦C­È¬O,
      '¬Oi°j°é¦C²Ä(Z°}¦C²ÄxÅܼƯÁ¤Þ¸¹­È)ÄæBrr°}¦C­È
      For x = 5 To 6
      '¡ô³]¶¶°j°é!x±q5¨ì6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         '¡ô¥ONÅܼƦC²ÄxÅܼÆÄæA°}¦C­È¬O,
         '¬Oi°j°é¦C²Ä(Z°}¦C²ÄxÅܼƯÁ¤Þ¸¹­È)ÄæBrr°}¦C­È+
         'i°j°é¦C²Ä(Z°}¦C(²ÄxÅܼÆ+2)¯Á¤Þ¸¹­È)ÄæBrr°}¦C­È
         A(N, x + 14) = A(N, x)
         '¡ô¥ONÅܼƦC²Ä(xÅܼÆ+14)ÄæA°}¦C­È¬O NÅܼƦC²ÄxÅܼÆÄæA°}¦C­È
      Next
      Y(S1) = A: GoTo i01
      '¡ô¥O¥HS1ÅܼƬ°key,item¬OA°}¦C,¯Ç¤JY¦r¨å(­«½Ækey«h¨ú¥N¨äitem),
      '¸õ¨ì i01¼Ð¥Ü¦ì¸mÄ~Äò°õ¦æ
   End If
   C = Format(Brr(i, 4), "M") + 6
   '¡ô¥OC³oµu¾ã¼ÆÅܼƬO i°j°é¦C²Ä4ÄæBrr°}¦C­È¨ú¨ä¤é´Á¤ë¥÷«áÂà¼Æ¦r+6
   S2 = T11 & "|" & T12
   '¡ô¥OS2ÅܼƬO T11ÅÜ¼Æ ³s±µ"|" ¦A³s±µT12Åܼƪº·s¦r¦ê
   A(Y(S2), C) = Brr(i, 16) + Brr(i, 17)
   '¡ô¥O(S2ÅܼƷíkey¬dY¦r¨åitem­È)¦C²ÄCÅܼÆÄæA°}¦C­È¬O,
   '¬Oi°j°é¦C²Ä16ÄæBrr°}¦C­È + i°j°é¦C²Ä17ÄæBrr°}¦C­ÈÄæBrr°}¦C­È
   A(Y(S2), 20) = A(Y(S2), 20) - A(Y(S2), C)
   '¡ô¥O(S2ÅܼƷíkey¬dY¦r¨åitem­È)¦C²Ä20ÄæA°}¦C­È¬O,
   '¬O¦Û¨­°}¦C­È - (S2ÅܼƷíkey¬dY¦r¨åitem­È)¦C²ÄCÅܼÆÄæA°}¦C­È
   P = Brr(i, 14) + Brr(i, 15)
   '¡ô¥OP³oªø¾ã¼Æ¬O i°j°é¦C14ÄæBrr°}¦C­È + i°j°é¦C15ÄæBrr°}¦C­È
   A(Y(S2), 19) = A(Y(S2), 19) - P
   '¡ô¥O(S2ÅܼƷíkey¬dY¦r¨åitem­È)¦C²Ä19ÄæA°}¦C­È¬O,
   '¬O¦Û¨­°}¦C­È - PÅܼÆ
   Y(S1) = A
   '¡ô¥O¥HS1ÅܼƬ°key,item¬OA°}¦C,¯Ç¤JY¦r¨å(­«½Ækey«h¨ú¥N¨äitem)
   
i01:
Next
'====================================
For Each Yk In Y.keys
'¡ô³]³v¶µ°j°é!¥OYk³o³q¥Î«¬ÅܼƬOY¦r¨å¸Ìkey¤§¤@
   If IsArray(Y(Yk)) Then
   '¡ô¦pªG¥H YkÅܼƬdY¦r¨åªºitem­È¬O °}¦C?
      On Error Resume Next
      '¡ô¥Oµ{§Ç¹J¿ù¸õ¹L!¨ÃÄ~Äò°õ¦æ
      Sheets(Val(Yk) & "").Delete
      '¡ô¥O¥HYkÅܼÆÂন¼Æ­È¦A³s±µªÅ¦r¤¸ªº·s¦r¦êªº¦W¦r,
      '¥H¦¹¦r¦ê¦W¦rªº¤u§@ªí§R°£
      On Error GoTo 0
      '¡ô¥Oµ{§Ç«ì´_¥¿±`°»¿ù
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      '¡ô¥O¬ì¥Ø¾lÃBªí¥t¥~½Æ»s¤@­Ó¦P¼Ëªí©ñ¦b³Ì«e­±
      With Sheets(1)
      '¡ô¥H¤U¬OÃö©ó ³Ì«e­±³o¤u§@ªíªºµ{§Ç
         .Name = Val(Yk)
         '¡ô¥O¦W¦r§ï¬°YkÅܼÆÂà¤Æ¬°¼Æ¦rªº¦r¦ê
         .UsedRange.Offset(5, 0).Delete
         '¡ô¥O¦³¨Ï¥ÎªºÀx¦s®æ½d³ò¦V¤U°¾²¾5¦Cªº½d³ò§R°£
         With .[A5].Resize(Y(Yk & "|r"), 20)
         '¡ô¥H¤U¬OÃö©óªí¸Ì[A5]ÂX®i¦V¤UY(Yk & "|r")¦C,¦V¥k20Äæ½d³ò
         'Ãö©ó³o½d³òÀx¦s®æªºµ{§Ç
         'Y(Yk & "|r"):¬O¥HYkÅÜ¼Æ ³s±µ"|r"ªº·s¦r¦ê¬dY¦r¨åªºitem­È
            .Value = Y(Yk)
            '¡ô¥OÀx¦s®æ­È¬O ¥HYkÅܼƬdY¦r¨å±o¨ìªº°}¦C­È
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
           '¡ô¥O[E:T]»P¦¹½d³òÀx¦s®æ¥æ¶°ªº½d³òÀx¦s®æ®æ¦¡¬O"~~~~~"
         End With
         .[C3] = Y(Yk & "/c")
         '¡ô¥Oªí¸Ì[C3]Àx¦s®æ­È¬O ¥HYk ³s±µ"/c"¦r¦ê¦¨ªº·s¦r¦ê,
         '¦¹¦r¦ê¬dY¦r¨å±o¨ìªº item­È
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         '¡ô¥Oªí¸Ì[C3]Àx¦s®æ­È¬O ¦Û¨­¦r¦ê ³s±µ"¡m",
         '¦A³s±µ ¥HYk ³s±µ"/c"¦r¦ê¦¨ªº·s¦r¦ê,³Ì«á³s±µ"¡n" ¦¨ªº·s¦r¦ê
         N = .Cells(Rows.Count, "F").End(3).Row
         '¡ô¥ONÅܼƬOFÄæ³Ì«á¦³¤º®eÀx¦s®æ¦C¸¹
         With .Cells(N + 1, "F").Resize(1, 15)
         '¡ô¥H¤U¬O Ãö©óªí¸Ì(NÅܼÆ+1)¦CFÄæÀx¦s®æÂX®i¦V¥k15Ä檺µ{§Ç
            .Value = "=SUM(F5:F" & N & ")"
            '¡ô¥O³o¨ÇÀx¦s®æ­È¬O "=SUM(F5:F" ³s±µNÅÜ¼Æ ¦A³s±µ")",
            '¦¹³s±µ¦¨ªº·s¦r¦ê©ñ¤J¦UÀx¦s®æ«á·|¦]¬°³Ì«e­±ªº"="²Å¸¹,
            '¸Ì­±ªºÄæ¦ì²Å¸¹·|ÀH¦U¤£¦PÄæ¦ì°µÅܤÆ
            If .Item(14) <> .Item(15) Then .Item(14) = "NA"
            '¡ô¦pªGµ²ªGªíÁ`¾lÃB¦X­p SÄæ<>TÄæ!´NÅýSÄæÅã¥Ü "NA"
            '§_«hSÄæ¦PTÄæ
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
'¡ô¥OÄÀ©ñÅܼÆ
End Sub

Andy2483

¦^´_ 18# shuo1125


1.²K¥[ÅçÃÒ ¸ê®Æ°ÏÁ`¾lÃB»P ¬ì¥Ø¾lÃB©ú²Ó¦X­p¾lÃB,¤è®×¦p¤U
2.¸ê®Æ°Ï7407492§ï¬°7407491°µÅçÃÒµ²ªG¦p¤U¹Ï

¤U¸ü (180.67 KB)

2023-3-22 14:45

Option Explicit
Sub TEST()
Application.DisplayAlerts = False
Dim Brr, A, Y, Z, Yk, T2$, T3$, T8$, T11$, T12$, T20$, S1$, S2$
Dim x%, C%, N&, i&, P&, Crr(1 To 1000, 1 To 20)
Set Y = CreateObject("Scripting.Dictionary")
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
Brr = Sheets("¸ê®Æ°Ï").UsedRange
For i = 2 To UBound(Brr)
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   A = Y(S1): Y(S1 & "/¾lÃB") = Brr(i, 18)
   If Not IsArray(A) Then A = Crr
   T8 = Brr(i, 8): T11 = Brr(i, 11)
   T12 = Brr(i, 12): T20 = Brr(i, 20)
   If InStr("/¨R±b/¥ß±b/", "/" & T20 & "/") = 0 Then
      Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
      MsgBox "TÄ椣©ú ¥ß¨R±bÃþ§O": Exit Sub
   End If
   If T20 = "¨R±b" Then
      If T11 Like "#####*" = False Then
         Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
         MsgBox "¨R±b³ÆµùÄ沧±`": Exit Sub
      End If
      If Y.Exists(T11 & "|" & T12) = Empty Then
         Application.GoTo Sheets("¸ê®Æ°Ï").Rows(i)
         MsgBox "µLªk¨R±b": Exit Sub
      End If
   End If
   If T20 = "¥ß±b" Then
      N = Y(S1 & "|r"): N = N + 1: Y(S1 & "|r") = N
      S2 = T8 & "|" & T12: Y(S2) = N
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      For x = 5 To 6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         A(N, x + 14) = A(N, x)
      Next
      Y(S1) = A: GoTo i01
   End If
   C = Format(Brr(i, 4), "M") + 6
   S2 = T11 & "|" & T12
   A(Y(S2), C) = Brr(i, 16) + Brr(i, 17)
   A(Y(S2), 20) = A(Y(S2), 20) - A(Y(S2), C)
   P = Brr(i, 14) + Brr(i, 15)
   A(Y(S2), 19) = A(Y(S2), 19) - P
   Y(S1) = A
   
i01:
Next
'====================================
For Each Yk In Y.keys
   If IsArray(Y(Yk)) Then
      On Error Resume Next
      Sheets(Val(Yk) & "").Delete
      On Error GoTo 0
      Sheets("¬ì¥Ø¾lÃBªí").Copy Before:=Sheets(1)
      With Sheets(1)
         .Name = Val(Yk)
         .UsedRange.Offset(5, 0).Delete
         With .[A5].Resize(Y(Yk & "|r"), 20)
            .Value = Y(Yk)
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
         End With
         .[C3] = Y(Yk & "/c")
         .[C3] = .[C3] & "¡m" & Y(Yk & "/b") & "¡n"
         N = .Cells(Rows.Count, "F").End(3).Row
         With .Cells(N + 1, "F").Resize(1, 15)
            .Value = "=SUM(F5:F" & N & ")"
            If .Item(14) <> .Item(15) Then .Item(14) = "NA"
            If Y(Yk & "/¾lÃB") <> .Item(15) Then
               .Item(15)(2) = "¡ôÄY­«¿ù»~!¾lÃB¦X­p" & _
               "¤£µ¥©ó¸ê®Æ°Ï¾lÃB: " & vbLf & Y(Yk & "/¾lÃB")
               .Interior.ColorIndex = 3
               MsgBox "ÄY­«¿ù»~"
               Exit Sub
            End If
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub

Andy2483

¦^´_ 22# shuo1125


    «e½ú¦­¦w,ÁÂÁµoªí¥DÃD»P½d¨Òµ¹«á¾Ç¾Ç²ß,ÁÂÁ½׾Â
1.´£¿ô«e½ú ¸ê®Æ°Ïªíªº¸ê®Æ¦b ¨t²Î¸Ì±Æ§Ç¦n¤~¼´¥X,´N¤£¥²¦bexcel±Æ§Ç
2.­Y¦³«áÄò°ÝÃD,½Ð¤£§[¦A´£¥X,¦pªG°¾Â÷¦¹¥DÃD,½Ð¥t¶}·s¥DÃD
3.½Ð«e½ú±`¤W½×¾Â¤@°_¾Ç²ß