返回列表 上一主題 發帖

[發問] 以字典方式製作餘額明細表

[發問] 以字典方式製作餘額明細表

本帖最後由 shuo1125 於 2023-3-18 18:56 編輯

各位前輩好!
想以字典法製作科目餘額明細,但條件涉及複雜真的弄不出來...
需求如下:
工作表為Sheet01資料區,Sheet02科目餘額表(套表),其餘為轉出之各科目表。
一、資料區S欄為借貸餘,此部分用於餘額決定借-貸還是貸-借。
二、判斷條件為1.科目編號(B欄) 2.傳票編號-序(H欄) 3.幣別(L欄) 4.原幣金額(N : O欄) 5.本幣金額(P : Q欄) 6.沖銷的號碼註記(K欄) 7.借貸餘(S欄)。
三、判斷資料區B欄科目,同科目明細 依上述條件當月沖銷變化帶入科目餘額表(套表)中。
科目餘額表(套表)1-12月為本幣數不需處理原幣之變化,但原幣餘額需表達在S欄。
詳如附件,請問各位高手這有辦法處理嗎...
以上,再麻煩了,謝謝!!

TEXT20230318.zip (17.83 KB)

回復 33# Andy2483
首先感謝Andy大幫忙,
但現在發現了個問題....
K欄單月發生單號重複沖銷時,月金額需累計。
請看圖檔及範例,嘗試幾次都無法執行....再次求助勞煩了!
單月金額未累加.PNG
2023-11-16 11:41
科目餘額表20231116.zip (49.19 KB)

TOP

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

本帖最後由 Andy2483 於 2023-3-29 10:33 編輯

謝謝前論壇,謝謝前輩
後學藉此帖練習把字典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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 29# Andy2483
Andy大!
這方法可行,可是有個問題..因為該方式是直接整理資料區,若我要再回頭查2023/02/28的資料就沒有了...
範例是我篩選出1月的資料,請問可以在不刪除情況下只抓查詢日的明細嗎?勞煩了...!!

TOP

本帖最後由 Andy2483 於 2023-3-28 09:22 編輯

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 25# Andy2483
Andy大!
若要將餘額明細表的B1日期考慮進去,假設說餘額區B1日期是2023/01/31(圖A),
則餘額明細只抓到1月底(圖B),
請問這樣該如何修改才好?如圖,又要勞煩你了...謝謝!!!
圖A.png
圖B.png

TOP

回復 25# Andy2483
Andy大!
   經測試可行,感激不盡!!

TOP

本帖最後由 Andy2483 於 2023-3-27 10:11 編輯

回復 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 要用心,不要操心、煩心。
返回列表 上一主題