Option Explicit
Sub TEST3()
Dim Brr, Z, i&, c, T$, T1$, T2$, T3$, a, b, d
Dim ColNum As Long
c = Application.Match([Invoice!G5], [Data!1:1], 0)
If IsError(c) Then
ColNum = Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets("Data").Cells(1, ColNum + 1) = Worksheets("Invoice").Cells(5, 7)
End If
c = Application.Match([Invoice!G5], [Data!1:1], 0)
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([Invoice!F10], [Invoice!C65536].End(3))
For i = 1 To UBound(Brr)
T1 = Trim(Brr(i, 1)): T2 = Val(Brr(i, 2)): T3 = Val(Brr(i, 3)): T = T1 & "/" & T2 & "/" & T3
If T1 = "" Then GoTo i01
Z(T) = Val(Brr(i, 4))
i01: Next
Brr = [Data!A1].CurrentRegion
For i = 2 To UBound(Brr)
T1 = Trim(Brr(i, 1)): T2 = Val(Brr(i, 2)): T3 = Val(Brr(i, 3)): T = T1 & "/" & T2 & "/" & T3
If T1 = "" Or Z(T) = "" Then Brr(i - 1, 1) = "": GoTo i02
Brr(i - 1, 1) = Z(T)
i02: Next
[Data!A1].Item(2, c).Resize(UBound(Brr) - 1) = Brr
a = Worksheets("Data").Range("A1").End(xlDown).Row
d = Worksheets("Data").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To a
Worksheets("Data").Cells(i, 5) = Worksheets("Data").Cells(i, 4) - Application.WorksheetFunction.Sum(Worksheets("Data").Range(Cells(i, 6), Cells(i, d + 1)))
Next i
Sub Test_A1()
Dim Arr, Brr, xD, xZ As Range, xF As Range, T$, R&, C&, i&
T = [Invoice!G5] '單號
If Not T Like "INV########" Then Exit Sub '單號不符合INV+8位日期..跳出
Set xZ = [Data!a1].Cells(1, Columns.Count).End(1) '找data第一行最後非空
Set xF = [Data!1:1].Find(T, Lookat:=xlWhole) '找單號在data的欄位
If xF Is Nothing Then Set xZ = xZ(1, 2): Set xF = xZ '若單號不存在, 增加一欄
Set xD = CreateObject("Scripting.Dictionary")
'-------------------------------
Arr = Range([Data!c1], [Data!a1].Cells(Rows.Count, 1).End(3))
Arr(1, 1) = T '將Arr第一欄首格放入"單號"
For i = 2 To UBound(Arr)
T = Arr(i, 1) & "\" & Arr(i, 2) & "\" & Arr(i, 3)
xD(T) = i '字典記憶行位置
Arr(i, 1) = 0 '將Arr第一欄放入0, 以備填入數量
Next i
'----------------------------
Brr = Range([Invoice!h1], [Invoice!a1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
R = xD(Brr(i, 3) & "\" & Brr(i, 4) & "\" & Brr(i, 5))
If R > 0 Then Arr(R, 1) = Arr(R, 1) + Brr(i, 6)
Next i
'----------------------------
xF.Resize(UBound(Arr)).Value = Arr
With Range([Data!F1], xZ).Resize(UBound(Arr)) '單號欄格式
.ColumnWidth = 15 '統一欄寬
.Borders.LineStyle = 1 '加框
.HorizontalAlignment = xlCenter '縱置中
.VerticalAlignment = xlCenter '橫置中
End With
[Data!e2].Resize(UBound(Arr) - 1) = "=D2-SUM(F2:" & xZ(2).Address(0, 0) & ")" 'E欄"結餘"公式(隨欄數變化)..刪去欄也可正確計算
End Sub作者: 198188 時間: 2024-2-29 10:43
Sub Test_A1()
Dim Arr, Brr, xD, xZ As Range, xF As Range, T$, R&, C&, i&, A, B
A = Worksheets("Data").Range("A1").End(xlDown).Row
For B = 2 To A
Worksheets("Data").Cells(B, 4) = Worksheets("Data").Cells(B, 5)
Next B
T = [data!E1] 'invoice no
Set xZ = [Data!a1].Cells(1, Columns.Count).End(1) 'Find Data last column
Set xF = [Data!1:1].Find(T, Lookat:=xlWhole) 'Find invoice no from Data all column?
If xF Is Nothing Then Set xZ = xZ(1, 2): Set xF = xZ 'if don't find, add one column
Set xD = CreateObject("Scripting.Dictionary")
'-------------------------------
Arr = Range([Data!c1], [Data!a1].Cells(Rows.Count, 1).End(3))
Arr(1, 1) = T 'put Arr first column on invoice
For i = 2 To UBound(Arr)
T = Arr(i, 1) & "\" & Arr(i, 2) & "\" & Arr(i, 3)
xD(T) = i 'record column place
Arr(i, 1) = 0 'set Arr first column 0,for back up to input?
Next i
'----------------------------
Brr = Range([KH!E1], [KH!a1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
R = xD(Brr(i, 2) & "\" & Brr(i, 3) & "\" & Brr(i, 4))
If R > 0 Then Arr(R, 1) = Arr(R, 1) + Brr(i, 5)
Next i
'----------------------------
xF.Resize(UBound(Arr)).Value = Arr
[Data!F2].Resize(UBound(Arr) - 1) = "=E2-SUM(G2:" & xZ(2).Address(0, 0) & ")" 'Column E BAL.
'RESET AND DELETE OLD RECORD
End Sub作者: Andy2483 時間: 2024-2-29 11:13
