Board logo

標題: [發問] 以字典方式製作餘額明細表 [打印本頁]
作者: shuo1125    時間: 2023-3-18 18:51     標題: 以字典方式製作餘額明細表

本帖最後由 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欄。
詳如附件，請問各位高手這有辦法處理嗎...
以上，再麻煩了，謝謝！！
作者: 准提部林    時間: 2023-3-19 14:27

只拉出"立帳"的行???
有跨年, 模擬結果與資料月份也對不上!!!
作者: shuo1125    時間: 2023-3-19 16:27

本帖最後由 shuo1125 於 2023-3-19 16:40 編輯

回復 2# 准提部林
準大好!
確實是只需要列出立帳的明細....模擬資料有點誤差我更正一版並附上需要"結果說明"。
以科目表達至截止日沖銷完成之明細(例:借餘，模擬結果為扣掉貸方沖銷後剩餘之明細，但沖銷後為0者還是要顯示。)
暫時只需要記錄當年變化就好，因年初我會更新餘額，所以是以年初各科目餘額+本年明細帳變化去做。
詳如附檔，抱歉表達不清..可在勞煩準大協助嗎?
作者: singo1232001    時間: 2023-3-20 12:57

本帖最後由 singo1232001 於 2023-3-20 13:03 編輯

回復 3# shuo1125


這有2個問題 待釐清

A:
立帳 與沖帳  目前看來有點問題
1.無關鍵資料欄位能夠判斷 兩筆是否同一筆
2.只能模糊的用金額判斷是否相同, 也有可能發生金額不同的沖帳
3.反之若只依照同科目編號 與 金額相同來判斷是否同一筆  那就可能會有錯誤

B:
沖帳時的月份
若10901 ,11001,11101 跨年度都要算在一月嗎?

檔案並未製作完成 只是練習用而已
作者: shuo1125    時間: 2023-3-20 14:22

本帖最後由 shuo1125 於 2023-3-20 14:29 編輯

回復 4# singo1232001
慶大好!

A:
立帳 與沖帳目前看來有點問題
1.無關鍵資料欄位能夠判斷 兩筆是否同一筆
  >關鍵在資料區的K欄的"備註"，其實是我將期初數更新後，與當期明細帳合併在同一工作表表達。
    (以圖AB為例，111/03/11立了一筆11103110001-10金額$235,104，112/01/18發生沖帳備註沖銷編號在資料區K欄此筆沖銷金額$235,104，
    立帳時為11103110001-10這筆，沖帳是發生在112/01月所以不用記錄該傳票編號-序，只將沖銷金額表達在立帳的1-12月月沖銷數中。)

2.只能模糊的用金額判斷是否相同, 也有可能發生金額不同的沖帳
  >比對條件基本上是以立帳的傳票編號-序來看，基本上與資料區K欄(圖A)沖銷的備註一定會相等(一筆對沖一筆)，皆不考慮比對金額只要表達沖銷月發生之沖銷額就好。

3.反之若只依照同科目編號 與 金額相同來判斷是否同一筆  那就可能會有錯誤
  >K欄註記的編號正常都是單筆沖銷，若傳票編號-序為5碼等同，不考慮金額只表達立帳沖銷月發生之沖銷金額。
B:
沖帳時的月份
  >只要沖銷年月在當月，就都是變化再1月，立帳明細有跨年為正常，因是月初剩下的餘額明細。(以圖A來看，11201發生沖銷，所以變化就都在表達在1月。)

以上，表達一直不清造成困擾在此深感抱歉....再請協助!!
作者: Andy2483    時間: 2023-3-21 13:53

本帖最後由 Andy2483 於 2023-3-21 14:03 編輯

回復 3# shuo1125


    謝謝前輩發表此主題與範例
後學藉此主題練習陣列與字典的解決方案如下,請前輩參考

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 "沖*" = 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 "*月帳款" Then
         B(0) = Mid(Split(T10, "月")(0), 2)
         B(0) = B(0) & Replace(T10, "沖", ".#0-")
         B(0) = Replace(B(0), "月帳款", "應付帳款總額")
      ElseIf T10 Like "沖###/*#/*#*" 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 "沖?????*  ###/*#/*#" 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("科目餘額表").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 & ")"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A, B
End Sub
作者: shuo1125    時間: 2023-3-21 21:20

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

回復 6# Andy2483
Andy2483大好!
我發現其實是上傳的模擬結果及資訊區皆有錯誤，怪不得當時準大會說有問題...
你針對錯的資訊還能做出對應的結果..
附上正確之版本..浪費了大家的時間...在此說聲抱歉!!
預計產出的結果為至截止日止立帳-沖帳後明細的餘額，沖帳時K欄註記的編號基本上會一對一沖銷。
(範例科目為2個，實際上會有多個..所以才想說以套表來產出各科目。)
作者: Andy2483    時間: 2023-3-22 07:23

回復 7# shuo1125


    謝謝前輩回復
1.正所謂當局者迷,解範例才知範例問題在哪裡
2.前輩多慮了,並沒有浪費時間,後學在論壇上在此帖上學習到很多知識

3.就後學的認知與經驗,備註欄屬於雜項欄位,做為關鍵字欄有很多疑慮,
請前輩查證一下K欄備註欄是否都只放 傳票編號-序(沖銷號碼)
作者: Andy2483    時間: 2023-3-22 08:01

本帖最後由 Andy2483 於 2023-3-22 08:26 編輯

回復 7# shuo1125


    以K欄備註欄都只放 傳票編號-序(沖銷號碼)的情境下做字典對照解決方案如下,
請前輩參考

K欄備註欄(傳票編號-序)沖銷H欄(傳票編號-序),一對多對沖銷是什麼規則??
[attach]36002[/attach]


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("科目餘額表").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 & ")"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub
作者: Andy2483    時間: 2023-3-22 08:35

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

回復 7# shuo1125

1.是以(幣別 + 傳票編號-序)美金沖銷美金,台幣沖銷台幣嗎?

2.結果表的S欄原幣餘額 總合計有意義嗎? 保留合計或取消合計?
PS:原幣餘額可能有多種幣別的餘額,相加被引用堪慮

Option Explicit
Sub TEST_幣別_傳票編號序()
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("科目餘額表").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"
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub
作者: shuo1125    時間: 2023-3-22 09:27

回復 8# Andy2483
Andy大大好!

1.正所謂當局者迷,解範例才知範例問題在哪裡
  >感謝你的體諒...
2.前輩多慮了,並沒有浪費時間,後學在論壇上在此帖上學習到很多知識
  >您的求知精神確實值得效仿，這裡很多熱心的高手，但我程度低落，僅能看看試著理解寫法.....
3.就後學的認知與經驗,備註欄屬於雜項欄位,做為關鍵字欄有很多疑慮,
  >是....但因現行沒有特殊能註記的欄位，制式的系統又無法新增欄位，所以才會填在備註...但基本上一定是單筆對沖。
     若是5碼的(例:11101)，只管其沖銷後的金額。
請前輩查證一下K欄備註欄是否都只放 傳票編號-序(沖銷號碼)
  >沖銷時放的K欄必定為傳票編號-序。
以上，多謝你的耐心回復!!!
作者: shuo1125    時間: 2023-3-22 09:50

本帖最後由 shuo1125 於 2023-3-22 10:04 編輯

回復 9# Andy2483
Andy大好!
1.是以(幣別 + 傳票編號-序)美金沖銷美金,台幣沖銷台幣嗎?
  >外幣沖銷外幣，台幣沖銷台幣。
2.結果表的S欄原幣餘額 總合計有意義嗎? 保留合計或取消合計?
  >原幣數不需要加總，因為會有幣別不同的狀況(會需要此欄位是因為要知道原幣剩多少)
PS:原幣餘額可能有多種幣別的餘額,相加被引用堪慮
  >確實是...多幣別時沖銷會表達不同幣別沖銷。(例:立帳編號11112 USD1,246 NTD38,003 沖帳時資訊為K欄11112 USD1,246 NTD38,003)
     請看圖C，需對應幣別沖銷。

(請看圖D，以1821來看，資料區最後餘額7,407,492會等於科目餘額的7,407,492)
以上，我是以期初數+本年明細做，所以沖銷時就列在各月裡就好，對同幣別進行沖銷(最後科餘餘額會等同於資料區各科目最後的餘額。)

敘述不清請再請理解...感謝各位相助!!
作者: Andy2483    時間: 2023-3-22 10:28

本帖最後由 Andy2483 於 2023-3-22 10:36 編輯

回復 12# shuo1125


    T欄 沖帳 對應K欄(備註)是空格,而不是 號碼(傳票編號-序)代表什麼意思?

[attach]36005[/attach]

請前輩查證一下K欄備註欄是否都只放 傳票編號-序(沖銷號碼)
  >沖銷時放的K欄必定為傳票編號-序。
作者: shuo1125    時間: 2023-3-22 10:43

本帖最後由 shuo1125 於 2023-3-22 10:46 編輯

回復 13# Andy2483
Andy大好!
該筆是立帳，後面的T欄錯了.....，所以K欄不會有沖銷編號。
(1821來看，該筆期初是借餘為立帳，貸餘時沖帳；2143期初貸餘則反之，貸餘為立帳，借餘為沖帳。)

以上，你真的很細心...謝謝你不吝其煩的回覆!!
作者: Andy2483    時間: 2023-3-22 10:49

本帖最後由 Andy2483 於 2023-3-22 10:50 編輯

回復 14# shuo1125


    因為K欄做對應可能不牢靠,需要更多驗證檢查
以下這問題也是手誤?還是系統撈資料就錯?
立帳 K欄有號碼
還是其他因素?

[attach]36006[/attach]
作者: shuo1125    時間: 2023-3-22 11:04

本帖最後由 shuo1125 於 2023-3-22 11:12 編輯

回復 15# Andy2483
Andy大好!
立沖帳T欄為公式帶入，因是我作範例時填錯第16.17列T欄反了....非原始系統產製資料。
立帳時備註可能會有其他編號，基本條件為科目代號、備註、幣別、借貸餘去判斷.....
(只有沖帳時K欄才有意義，紀錄對應的傳票編號-序)
以上，謝謝你!!
作者: Andy2483    時間: 2023-3-22 11:12

本帖最後由 Andy2483 於 2023-3-22 11:18 編輯

回復 16# shuo1125


    謝謝前輩,請試試看

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 = "沖帳" 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"
            '↑結果表總餘額合計 如果S欄<>T欄!就讓S欄顯示 "NA"
            '否則S欄同T欄
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
End Sub
作者: shuo1125    時間: 2023-3-22 11:33

回復 17# Andy2483
Andy大好!
針對我問題感謝你的大力協助....
你的程序範例檔已可使用，但我用在實際上要使用的明細中會出錯...
這部分應該就是我資料檔自己的問題...我在想辦法自行修正...
在此感謝你勞心了，謝謝您!
作者: Andy2483    時間: 2023-3-22 13:32

本帖最後由 Andy2483 於 2023-3-22 13:54 編輯

回復 18# shuo1125


    謝謝前輩再回復
後學藉此主題學習到很多知識,學習心得註解如下,請前輩參考,請各位前輩指教
如果還有後學可以學習的!請前輩繼續提出

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)
'↑宣告變數:(Brr,A,Y,Z,Yk)是通用型變數,
'(T2,T3,T8,T11,T20,T12,S1,S2)是字串變數,(x,C)是短整數變數,
'(N,i,P)是長整數變數,Crr是陣列變數(縱向1到1000,橫向1到20)
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Z = Array(, 4, 8, 10, 12, 14, 16, 15, 17)
'↑令Z這通用型變數是一維陣列(共9個陣列值,索引號0到8)
Brr = Sheets("資料區").UsedRange
'↑令Brr這通用型變數是二維陣列,以資料區表有使用儲存格值帶入
For i = 2 To UBound(Brr)
'↑設順迴圈!i從2到Brr陣列縱向最大索引列號
   T2 = Brr(i, 2): T3 = Brr(i, 3)
   '↑令T2這字串變數是 i迴圈列第2欄Brr陣列值,
   '令T3這字串變數是 i迴圈列第3欄Brr陣列值
   S1 = T2 & "|" & T3: Y(S1 & "/b") = T2: Y(S1 & "/c") = T3
   '↑令S1這字串變數是 T2變數 連接"|" 再連接T3變數的新字串,
   '令以S1變數 連接"/b"成的新字串當key,item是T2變數,納入Y字典
   '令以S1變數 連接"/c"成的新字串當key,item是T3變數,納入Y字典
   A = Y(S1)
   '↑令A這通用型變數是 以S1變數查Y字典得到的item值
   If Not IsArray(A) Then A = Crr
  '↑如果A變數經判斷:不是陣列!就令A變數是Crr變數
   T8 = Brr(i, 8): T11 = Brr(i, 11)
   T12 = Brr(i, 12): T20 = Brr(i, 20)
   '↑令T8這字串變數是 i迴圈列第8欄Brr陣列值,
   '令T11這字串變數是 i迴圈列第11欄Brr陣列值,
   '令T12這字串變數是 i迴圈列第12欄Brr陣列值
   '令T20這字串變數是 i迴圈列第20欄Brr陣列值
   If InStr("/沖帳/立帳/", "/" & T20 & "/") = 0 Then
   '↑如果T20變數不是 沖帳 ,也不是 立帳??
      Application.GoTo Sheets("資料區").Rows(i)
      '↑令儲存格游標跳到i變數列
      MsgBox "T欄不明 立沖帳類別": Exit Sub
      '↑跳出提示窗~~~:結束程式執行
   End If
   If T20 = "沖帳" Then
   '↑如果T20變數是 "沖帳"字串 ?
      If T11 Like "#####*" = False Then
      '↑如果T11變數不是以5個連續數字開頭的字串?
         Application.GoTo Sheets("資料區").Rows(i)
         '↑令儲存格游標跳到i變數列
         MsgBox "沖帳備註欄異常": Exit Sub
         '↑跳出提示窗~~~:結束程式執行
      End If
      If Y.Exists(T11 & "|" & T12) = Empty Then
      '↑如果以T11變數 連接"|" 再連接T12變數的新字串,
      '查Y字典裡沒有這key??
         Application.GoTo Sheets("資料區").Rows(i)
         '↑令儲存格游標跳到i變數列
         MsgBox "無法沖帳": Exit Sub
         '↑跳出提示窗~~~:結束程式執行
      End If
   End If
   If T20 = "立帳" Then
   '↑如果T20變數 "立帳"字串
      N = Y(S1 & "|r"): N = N + 1: Y(S1 & "|r") = N
      '↑令N這長整數變數是 (S1變數連接"|r"成的新字串)查Y字典的item值
      '令N變數累加1,
      '令(S1變數連接"|r"成的新字串)的item值是 N變數
      S2 = T8 & "|" & T12: Y(S2) = N
      '↑令S2這字串變數是 T8變數 連接"|" 再連接T12變數的新字串,
      '↑令以S2變數當key,item是N變數,納入Y字典裡
      For x = 1 To 4: A(N, x) = Brr(i, Z(x)): Next
      '↑設順迴圈!x從1到4,令N變數列第x變數欄A陣列值是,
      '是i迴圈列第(Z陣列第x變數索引號值)欄Brr陣列值
      For x = 5 To 6
      '↑設順迴圈!x從5到6
         A(N, x) = Brr(i, Z(x)) + Brr(i, Z(x + 2))
         '↑令N變數列第x變數欄A陣列值是,
         '是i迴圈列第(Z陣列第x變數索引號值)欄Brr陣列值+
         'i迴圈列第(Z陣列(第x變數+2)索引號值)欄Brr陣列值
         A(N, x + 14) = A(N, x)
         '↑令N變數列第(x變數+14)欄A陣列值是 N變數列第x變數欄A陣列值
      Next
      Y(S1) = A: GoTo i01
      '↑令以S1變數為key,item是A陣列,納入Y字典(重複key則取代其item),
      '跳到 i01標示位置繼續執行
   End If
   C = Format(Brr(i, 4), "M") + 6
   '↑令C這短整數變數是 i迴圈列第4欄Brr陣列值取其日期月份後轉數字+6
   S2 = T11 & "|" & T12
   '↑令S2變數是 T11變數 連接"|" 再連接T12變數的新字串
   A(Y(S2), C) = Brr(i, 16) + Brr(i, 17)
   '↑令(S2變數當key查Y字典item值)列第C變數欄A陣列值是,
   '是i迴圈列第16欄Brr陣列值 + i迴圈列第17欄Brr陣列值欄Brr陣列值
   A(Y(S2), 20) = A(Y(S2), 20) - A(Y(S2), C)
   '↑令(S2變數當key查Y字典item值)列第20欄A陣列值是,
   '是自身陣列值 - (S2變數當key查Y字典item值)列第C變數欄A陣列值
   P = Brr(i, 14) + Brr(i, 15)
   '↑令P這長整數是 i迴圈列14欄Brr陣列值 + i迴圈列15欄Brr陣列值
   A(Y(S2), 19) = A(Y(S2), 19) - P
   '↑令(S2變數當key查Y字典item值)列第19欄A陣列值是,
   '是自身陣列值 - P變數
   Y(S1) = A
   '↑令以S1變數為key,item是A陣列,納入Y字典(重複key則取代其item)
   
i01:
Next
'====================================
For Each Yk In Y.keys
'↑設逐項迴圈!令Yk這通用型變數是Y字典裡key之一
   If IsArray(Y(Yk)) Then
   '↑如果以 Yk變數查Y字典的item值是 陣列?
      On Error Resume Next
      '↑令程序遇錯跳過!並繼續執行
      Sheets(Val(Yk) & "").Delete
      '↑令以Yk變數轉成數值再連接空字元的新字串的名字,
      '以此字串名字的工作表刪除
      On Error GoTo 0
      '↑令程序恢復正常偵錯
      Sheets("科目餘額表").Copy Before:=Sheets(1)
      '↑令科目餘額表另外複製一個同樣表放在最前面
      With Sheets(1)
      '↑以下是關於 最前面這工作表的程序
         .Name = Val(Yk)
         '↑令名字改為Yk變數轉化為數字的字串
         .UsedRange.Offset(5, 0).Delete
         '↑令有使用的儲存格範圍向下偏移5列的範圍刪除
         With .[A5].Resize(Y(Yk & "|r"), 20)
         '↑以下是關於表裡[A5]擴展向下Y(Yk & "|r")列,向右20欄範圍
         '關於這範圍儲存格的程序
         'Y(Yk & "|r"):是以Yk變數 連接"|r"的新字串查Y字典的item值
            .Value = Y(Yk)
            '↑令儲存格值是 以Yk變數查Y字典得到的陣列值
            Intersect([E:T], .Cells).NumberFormatLocal = _
            "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-"
           '↑令[E:T]與此範圍儲存格交集的範圍儲存格格式是"~~~~~"
         End With
         .[C3] = Y(Yk & "/c")
         '↑令表裡[C3]儲存格值是 以Yk 連接"/c"字串成的新字串,
         '此字串查Y字典得到的 item值
         .[C3] = .[C3] & "《" & Y(Yk & "/b") & "》"
         '↑令表裡[C3]儲存格值是 自身字串 連接"《",
         '再連接 以Yk 連接"/c"字串成的新字串,最後連接"》" 成的新字串
         N = .Cells(Rows.Count, "F").End(3).Row
         '↑令N變數是F欄最後有內容儲存格列號
         With .Cells(N + 1, "F").Resize(1, 15)
         '↑以下是 關於表裡(N變數+1)列F欄儲存格擴展向右15欄的程序
            .Value = "=SUM(F5:F" & N & ")"
            '↑令這些儲存格值是 "=SUM(F5:F" 連接N變數 再連接")",
            '此連接成的新字串放入各儲存格後會因為最前面的"="符號,
            '裡面的欄位符號會隨各不同欄位做變化
            If .Item(14) <> .Item(15) Then .Item(14) = "NA"
            '↑如果結果表總餘額合計 S欄<>T欄!就讓S欄顯示 "NA"
            '否則S欄同T欄
         End With
      End With
   End If
Next
Set Y = Nothing: Erase Brr, Crr, Z, A
'↑令釋放變數
End Sub
作者: Andy2483    時間: 2023-3-22 14:47

回復 18# shuo1125


1.添加驗證 資料區總餘額與 科目餘額明細合計餘額,方案如下
2.資料區7407492改為7407491做驗證結果如下圖
[attach]36007[/attach]


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 & "/餘額") = 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
作者: shuo1125    時間: 2023-3-22 17:28

回復 20# Andy2483
Andy大好!
你這效率太驚人了...我有空再做測試，
還提供多種解法及註解..謝謝你!
作者: shuo1125    時間: 2023-3-22 22:51

回復 20# Andy2483
Andy大!
經測試過後可使用，感謝你屢次協助...
作者: Andy2483    時間: 2023-3-23 07:14

回復 22# shuo1125


    前輩早安,謝謝發表主題與範例給後學學習,謝謝論壇
1.提醒前輩 資料區表的資料在 系統裡排序好才撈出,就不必在excel排序
2.若有後續問題,請不吝再提出,如果偏離此主題,請另開新主題
3.請前輩常上論壇一起學習
作者: shuo1125    時間: 2023-3-23 23:38

回復 23# Andy2483
Andy大!

1.提醒前輩 資料區表的資料在 系統裡排序好才撈出,就不必在excel排序
  >好的，謝謝提醒...
2.若有後續問題,請不吝再提出,如果偏離此主題,請另開新主題
  >有時候是怕耽擱大家時間，若有特別問題在提出了..
3.請前輩常上論壇一起學習
  >我程度不夠，只能慢慢摸索了...謝謝你的協助!
作者: Andy2483    時間: 2023-3-27 08:25

本帖最後由 Andy2483 於 2023-3-27 08:42 編輯

回復 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    時間: 2023-3-27 10:07

本帖最後由 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
作者: shuo1125    時間: 2023-3-27 10:08

回復 25# Andy2483
Andy大!
   經測試可行，感激不盡!!
作者: shuo1125    時間: 2023-3-27 20:25

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

本帖最後由 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
作者: shuo1125    時間: 2023-3-28 12:38

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

回復 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    時間: 2023-3-29 10:31

本帖最後由 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
作者: Andy2483    時間: 2023-4-28 07:48

回復 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    時間: 2023-11-16 11:42

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)