Andy2483

回復 7# shuo1125


    謝謝前輩
以下是後學練習儲存格與陣列對照應用的R欄餘額計算解決方案,請前輩參考

Option Explicit
Sub 資料區餘額()
Dim Arr, T16&, T17&, T18&, i&, S&, T$, T2$, T3$, T20$, xR As Range
'↑宣告變數:Arr是通用型變數,(T16,T17,T18,i)是長整數,
'(T,T2,T3,T20)是字串變數
Set xR = Range([資料區!T1], [資料區!A1].Cells(Rows.Count, 1).End(3))
'↑令xR這儲存格變數是 資料區[T2]到 A欄最後有內容儲存格範圍儲存格
Arr = xR
'↑令Arr這通用型變數是 二維陣列,以 xR儲存格值帶入
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到 Arr陣列縱向最大索引列號
   If i = 1 Then GoTo i01
   '↑如果i變數是 1!就跳到 i01標示位置繼續執行
   T2 = Arr(i, 2): T3 = Arr(i, 3): T16 = Arr(i, 16)
   T17 = Arr(i, 17): T18 = Arr(i, 18): T20 = Arr(i, 20)
   '↑令T2這字串變數是 i迴圈列第2欄Arr陣列值,依此類推
    If Val(T16) > Val(T17) Then
    '↑如果T16變數經轉化的數值 大於 T17變數經轉化的數值??
       T18 = T16 - T17
       '↑if條件成立!就令 T18變數是 T16 - T17變數
       Else
          T18 = Val(T17) - Val(T16)
          '↑否則!就令 T18變數是 T17變數 - T16變數
    End If
   If T <> T2 & "|" & T3 Then
   '↑如果T這字串變數 不等於 T2變數連接 T3變數組成的新字串
      xR.Range("R" & i).Value = T18
      '↑令xR變數的[R2]儲存格值是 T18變數
      T = T2 & "|" & T3
      '↑令T這字串變數是 T2變數連接 T3變數組成的新字串
      ElseIf T20 = "立帳" Then
         xR.Range("R" & i) = xR.Range("R" & i - 1) + T18
         '↑否則令xR變數的R欄(i迴圈數)列儲存格值是
         'xR變數的R欄(i迴圈數-1)列儲存格值 +T18變數
      ElseIf T20 = "沖帳" Then
         xR.Range("R" & i) = xR.Range("R" & i - 1) - T18
         '↑否則令xR變數的R欄(i迴圈數)列儲存格值是
         'xR變數的R欄(i迴圈數-1)列儲存格值 -T18變數
   End If
i01:
Next
Erase Arr: Set xR = Nothing
'↑令釋放變數
End Sub

Andy2483

回復 24# shuo1125


    謝謝前輩
後學藉此帖發現這字典是個萬能的變數產生器
1.因為變數不會重複,所以key可以濾重複
2.因為key對應一個item(數字.字串.儲存格.陣列....),所以key可當成是一個變數


Option Explicit
Sub 資料區餘額_1()
Dim Y, Arr, T16&, T17&, T18&, i&, S&, T$, T2$, T3$, T20$, xR As Range
'↑宣告變數:(Y,Arr)是通用型變數,(T16,T17,T18,i)是長整數,
'(T,T2,T3,T20)是字串變數,xR是儲存格變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Set xR = Range([資料區!T2], [資料區!A1].Cells(Rows.Count, 1).End(3))
'↑令xR這儲存格變數是 資料區[T2]到 A欄最後有內容儲存格範圍儲存格
Arr = xR
'↑令Arr這通用型變數是 二維陣列,以 xR儲存格值帶入
For i = 1 To UBound(Arr)
'↑設順迴圈!i從1到 Arr陣列縱向最大索引列號
   T2 = Arr(i, 2): T3 = Arr(i, 3): T16 = Arr(i, 16)
   T17 = Arr(i, 17): T18 = Arr(i, 18): T20 = Arr(i, 20)
   '↑令T2這字串變數是 i迴圈列第2欄Arr陣列值,依此類推
   T18 = Abs(T16 - T17)
   '↑令T18這長整數變數是 T16變數 - T17變數後的絕對值數值
   T = T2 & "|" & T3
   '↑令T這字串變數是 T2變數連接 T3變數組成的新字串
   If Y(T) = "" And T20 = "沖帳" Then MsgBox "嚴重錯誤": Exit Sub
   '↑如果一開始就是沖帳!是嚴重錯誤得資料
   If T20 = "立帳" Then
   '↑如果 T20變數是 "立帳" ?
      Y(T) = Y(T) + T18
      '↑令T變數在Y字典item值累加 T18變數
      ElseIf T20 = "沖帳" Then
         '↑否則如果 T20變數是 "沖帳" ?
         Y(T) = Y(T) - T18
         '↑令T變數在Y字典item值累扣 T18變數
      Else
         MsgBox "無法辨識": Application.Goto xR(i, 20): Exit Sub
         '↑否則就跳出提示窗,儲存格游標跳到R欄i迴圈列位置:結束程式
   End If
   Arr(i, 18) = Y(T)
   '↑令i迴圈列第18欄Arr陣列值是T變數查Y字典的item值
Next
[A2].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
'↑令[A2]擴展向下Arr縱向最大索引列號數,擴展向右最大索引欄號數,
'這擴展範圍儲存格值以Arr陣列值帶入
Erase Arr: Set xR = Nothing: Set Y = Nothing
'↑令釋放變數
End Sub

Andy2483

回復 28# shuo1125


    謝謝前輩,謝謝論壇
後學練習運用 刪除指定條件列資料,學習的解決方案如下,請前輩參考
http://forum.twbts.com/thread-23898-1-2.html

Option Explicit
Sub 清除不符條件的列_並排序()
Dim Arr, Brr(), xArea As Range, x&, Xm&, y&, Ym&, N&, Da As Date
'↑宣告變數:Arr是 通用型變數,Brr是陣列,xArea是儲存格變數,其他是長整數變數
Da = Application.Text([科目餘額表!B1], "[$-404]e/m/d;@")
'↑令Da這日期變數是 [B1]以國年格式轉為文字再轉為日期的變數
With Range([資料區!U1], [資料區!A65536].End(3))
'↑以下是關於上述儲存格的程序
     Arr = .Value
     '↑令Arr這通用型變數是二維陣列,以這With程序儲存格值帶入
     Ym = UBound(Arr, 1)
     '↑令Ym這長整數變數是Arr陣列縱向最大索引列號數
     'PS:可以省略為 Ym = UBound(Arr)
     Xm = UBound(Arr, 2)
     '↑令Xm這長整數變數是Arr陣列橫向最大索引欄號數
     Set xArea = .Resize(Ym, Xm + 1)
     '↑令xArea這儲存格變數是 以這With程序儲存格擴展向下Ym變數列,
     '向右(Xm變數 + 1)欄
     '(PS:增加1輔助欄)
     ReDim Brr(1 To Ym, 0): Brr(1, 0) = 0
     '↑宣告Brr這陣列變數是二維的,
     '大小:縱向從1到Ym變數列,橫向1欄,索引號是0到0
     '↑令第1個Brr陣列值是 0
     For y = 2 To Ym
     '↑設順迴圈!y從1到Ym變數
         If CDate(Arr(y, 4)) > Da Then GoTo 101
         '↑如果y迴圈列第4欄Arr陣列值轉成日期後大於 Da變數!就跳到101位置繼續執行
         N = N + 1: Brr(y, 0) = N
         '↑令N這長整數變數累加 1:令y變數列0索引號欄Brr陣列值是 N變數
101: Next y
     If N = Ym - 1 Then Exit Sub
     '↑如果N變數=Ym變數-1!就結束程式執行(代表沒有符合條件的列)
     xArea.Columns(Xm + 1) = Brr
     '↑令xArea變數的(Xm變數+1)欄範圍儲存格以Brr陣列值帶入(PS:輔助欄帶入輔助索引值)
End With
With xArea
'↑以下是關於 xArea變數的程序
     .Sort KEY1:=.Item(Xm + 1), Order1:=xlAscending, Header:=xlNo
     '↑令xArea(儲存格)以(Xm變數+1)欄第1列儲存格所在的欄(AB欄)當基準,
     '做沒有標題列的順排序排序
     .Rows(N + 2 & ":" & Ym).Delete
     '↑令xArea變數範圍裡的第 (N變數 + 2)列到 範圍裡的Ym變數列,
     '這範圍儲存格列刪除
     .Columns(Xm + 1).Delete
     '↑令xArea變數的(Xm變數+1)欄範圍儲存格欄刪除 (PS:輔助欄刪除)
     .Sort _
     KEY1:=[B1], Order1:=xlAscending, _
     Key2:=[C1], Order2:=xlAscending, _
     key3:=[D1], Order3:=xlAscending, _
     Header:=xlYes, Orientation:=xlTopToBottom
     '↑令資料做3層次排序
End With
End Sub

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