Andy2483

¦^´_ 30# shuo1125


    ÁÂÁ«e½ú¤@°_¾Ç²ß

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
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)
On Error Resume Next
Sheets("ÅçÃÒªí").Delete
On Error GoTo 0
Sheets("¸ê®Æ°Ï").Copy Before:=Sheets(1)
With Sheets(1): .Name = "ÅçÃÒªí": End With

Brr = Range([ÅçÃÒªí!U1], [ÅçÃÒªí!A65536].End(3))
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


Sub ²M°£¤£²Å±ø¥óªº¦C_¨Ã±Æ§Ç()
Dim Arr, Brr(), xArea As Range, x&, Xm&, y&, Ym&, N&, Da As Date
Da = Application.Text([¬ì¥Ø¾lÃBªí!B1], "[$-404]e/m/d;@")
With Range([ÅçÃÒªí!U1], [ÅçÃÒªí!A65536].End(3))
     Arr = .Value
     Ym = UBound(Arr, 1)
     Xm = UBound(Arr, 2)
     Set xArea = .Resize(Ym, Xm + 1)
     ReDim Brr(1 To Ym, 0)
     For y = 2 To Ym
         If CDate(Arr(y, 4)) > Da Then GoTo 101
         N = N + 1: Brr(y, 0) = N
101: Next y
     If N = Ym - 1 Then Exit Sub
     xArea.Columns(Xm + 1) = Brr
End With
With xArea
     .Sort KEY1:=.Item(Xm + 1), Order1:=xlAscending, Header:=xlYes
     .Rows(N + 2 & ":" & Ym).Delete
     .Columns(Xm + 1).Delete
     .Sort _
     KEY1:=[B1], Order1:=xlAscending, _
     Key2:=[C1], Order2:=xlAscending, _
     key3:=[D1], Order3:=xlAscending, _
     Header:=xlYes, Orientation:=xlTopToBottom
End With
End Sub

Andy2483

ÁÂÁ«e½×¾Â,ÁÂÁ«e½ú
«á¾ÇÂǦ¹©«½m²ß§â¦r¨åkey´£¥X¨ÓÅܦ¨¤@ºû°}¦C,½Ð«e½ú°Ñ¦Ò


Option Explicit
Public Brr
Sub ¦¬¶°¤£­«½Æ_¬ì¥Ø¦WºÙ()
Dim i&, Crr, Y
Set Y = CreateObject("Scripting.Dictionary")
Crr = Range([B2], Cells(Rows.Count, "B").End(3))
For i = 1 To UBound(Crr)
   Y(Crr(i, 1)) = ""
Next
Brr = Y.keys
MsgBox Brr(0)
Set Y = Nothing: Erase Crr
End Sub

Andy2483

¦^´_ 30# shuo1125


    ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«¦V«e½ú»PÂsÄý³o¥DÃDªº«e½ú.¹C«È­Ì­Pºp,©êºp,¥H¤U¬O¾Ç²ß¤è®×­×¥¿

Sub ²M°£¤£²Å±ø¥óªº¦C_¨Ã±Æ§Ç()
Dim Arr, Brr(), xArea As Range, x&, Xm&, y&, Ym&, N&, Da As Date
'Da = Application.Text([¬ì¥Ø¾lÃBªí!B1], "[$-404]e/m/d;@")
'³o¬O¿ù»~ªºÆ[©À,«á¾Ç¾q¶w! ¤£À³¸Ó±N¦è¤¸¦~Âà´«¦¨¥Á°ê¦~
'¥¿½TÆ[©À½Ð°Ñ¦Ò³sµ²©«
http://forum.twbts.com/thread-23971-1-1.html
Da = [¬ì¥Ø¾lÃBªí!B1]
With Range([ÅçÃÒªí!U1], [ÅçÃÒªí!A65536].End(3))
     Arr = .Value
     Ym = UBound(Arr, 1)
     Xm = UBound(Arr, 2)
     Set xArea = .Resize(Ym, Xm + 1)
     ReDim Brr(1 To Ym, 0)
     For y = 2 To Ym
        'If CDate(Arr(y, 4)) > Da Then GoTo 101
        '«á¾Ç·í®É³g¤è«K¥H¬°±N¤é´Á³B¸Ì¦¨¦P¬°¥Á°ê¦~°µ¤ñ¸û,³o¬O¿ù»~ªºÆ[©À
        If CDate(Val(Arr(y, 4)) + 1911 & Mid(T, InStr(Arr(y, 4), "/"))) > Da Then GoTo 101
        '¸Ó±N¨âªÌ³£³B²z¦¨¦è¤¸¦~°µÅÞ¿è¹Bºâ,¤~¬O¥¿½Tªº¤èªk
         N = N + 1: Brr(y, 0) = N
101: Next y
     If N = Ym - 1 Then Exit Sub
     xArea.Columns(Xm + 1) = Brr
End With
With xArea
     .Sort KEY1:=.Item(Xm + 1), Order1:=xlAscending, Header:=xlYes
     .Rows(N + 2 & ":" & Ym).Delete
     .Columns(Xm + 1).Delete
     .Sort _
     KEY1:=[B1], Order1:=xlAscending, _
     Key2:=[C1], Order2:=xlAscending, _
     key3:=[D1], Order3:=xlAscending, _
     Header:=xlYes, Orientation:=xlTopToBottom
End With
End Sub

shuo1125

¦^´_ 33# Andy2483
­º¥ý·PÁÂAndy¤jÀ°¦£¡A
¦ý²{¦bµo²{¤F­Ó°ÝÃD....
KÄæ³æ¤ëµo¥Í³æ¸¹­«½Æ¨R¾P®É¡A¤ëª÷ÃB»Ý²Ö­p¡C
½Ð¬Ý¹ÏÀɤνd¨Ò¡A¹Á¸Õ´X¦¸³£µLªk°õ¦æ....¦A¦¸¨D§U³Ò·Ð¤F¡I

¤U¸ü (215.02 KB)

2023-11-16 11:41

¬ì¥Ø¾lÃBªí20231116.zip (49.19 KB)

¤U¸ü¦¸¼Æ: 2

2023-11-16 11:41