- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-12-5
|
回復 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 |
|
發表於 2023-3-28 13:26
| 
