Andy2483

回復 30# shuo1125


    謝謝前輩一起學習

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 & "/餘額") = 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("/沖帳/立帳/", "/" & T20 & "/") = 0 Then
      Application.Goto Sheets("驗證表").Rows(i)
      MsgBox "T欄不明 立沖帳類別": Exit Sub
   End If
   If T20 = "沖帳" Then
      If T11 Like "#####*" = False Then
         Application.Goto Sheets("驗證表").Rows(i)
         MsgBox "沖帳備註欄異常": Exit Sub
      End If
      If y.Exists(T11 & "|" & T12) = Empty Then
         Application.Goto Sheets("驗證表").Rows(i)
         MsgBox "無法沖帳": Exit Sub
      End If
   End If
   If T20 = "立帳" 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("科目餘額表").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] & "《" & y(Yk & "/b") & "》"
         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 & "/餘額") <> .Item(15) Then
               .Item(15)(2) = "↑嚴重錯誤!餘額合計" & _
               "不等於資料區餘額: " & vbLf & y(Yk & "/餘額")
               .Interior.ColorIndex = 3
               MsgBox "嚴重錯誤"
               Exit Sub
            End If
         End With
      End With
   End If
Next
Set y = Nothing: Erase Brr, Crr, Z, A
End Sub


Sub 清除不符條件的列_並排序()
Dim Arr, Brr(), xArea As Range, x&, Xm&, y&, Ym&, N&, Da As Date
Da = Application.Text([科目餘額表!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

謝謝前論壇,謝謝前輩
後學藉此帖練習把字典key提出來變成一維陣列,請前輩參考


Option Explicit
Public Brr
Sub 收集不重複_科目名稱()
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


    謝謝論壇,謝謝各位前輩,謝謝前輩發表此主題與範例
後學藉此帖向前輩與瀏覽這主題的前輩.遊客們致歉,抱歉,以下是學習方案修正

Sub 清除不符條件的列_並排序()
Dim Arr, Brr(), xArea As Range, x&, Xm&, y&, Ym&, N&, Da As Date
'Da = Application.Text([科目餘額表!B1], "[$-404]e/m/d;@")
'這是錯誤的觀念,後學駑鈍! 不應該將西元年轉換成民國年
'正確觀念請參考連結帖
http://forum.twbts.com/thread-23971-1-1.html
Da = [科目餘額表!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
        '後學當時貪方便以為將日期處裡成同為民國年做比較,這是錯誤的觀念
        If CDate(Val(Arr(y, 4)) + 1911 & Mid(T, InStr(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

shuo1125

回復 33# Andy2483
首先感謝Andy大幫忙，
但現在發現了個問題....
K欄單月發生單號重複沖銷時，月金額需累計。
請看圖檔及範例，嘗試幾次都無法執行....再次求助勞煩了！

下載 (215.02 KB)

2023-11-16 11:41

科目餘額表20231116.zip (49.19 KB)

下載次數: 2

2023-11-16 11:41