- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-10-30
|
14#
發表於 2022-5-31 12:25
| 只看該作者
回復 samwang
sam大
抱歉表達不清，簡言之就是將同科目金額匯總成一筆就好...
若不清楚詳附檔，麻煩您 ...
shuo1125 發表於 2022-5-31 10:12 
請再測試看看，謝謝
Sub test()
Dim Arr, xD, Brr(), T$, T1$, i&, n%, n1%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Sheet1.[A1].CurrentRegion
For i = 2 To UBound(Arr)
T = Arr(i, 3): T1 = Arr(i, 5)
If UCase(T1) = "S" Then
xD(T) = Array(Arr(i, 2), Arr(i, 4), Arr(i, 7), Arr(i, 10))
End If
Next
Arr = Sheet2.[A1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 7)
For i = 2 To UBound(Arr)
T = Arr(i, 1)
If xD.Exists(T) Then
T1 = xD(T)(0)
If xD1.Exists(T1) Then
n1 = xD1(T1)
If UCase(xD(T)(1)) = "DR" Then
If Arr(i, 10) > Arr(i, 11) Then
Brr(n1, 7) = Brr(n1, 7) + Arr(i, 10)
Else
Brr(n1, 7) = Brr(n1, 7) + Arr(i, 11)
End If
ElseIf UCase(xD(T)(1)) = "CR" Then
If Arr(i, 10) > Arr(i, 11) Then
Brr(n1, 7) = Brr(n1, 7) - Arr(i, 10)
Else
Brr(n1, 7) = Brr(n1, 7) - Arr(i, 11)
End If
End If
Else
n = n + 1: xD1(T1) = n: Brr(n, 3) = xD(T)(2)
Brr(n, 1) = xD(T)(0): Brr(n, 2) = xD(T)(3)
If UCase(xD(T)(1)) = "DR" Then
If Arr(i, 10) > Arr(i, 11) Then
Brr(n, 7) = Arr(i, 10)
Else
Brr(n, 7) = Arr(i, 11)
End If
ElseIf UCase(xD(T)(1)) = "CR" Then
If Arr(i, 10) > Arr(i, 11) Then
Brr(n, 7) = -Arr(i, 10)
Else
Brr(n, 7) = -Arr(i, 11)
End If
End If
End If
End If
99: Next
If n > 0 Then
With Sheet3
.[a7].CurrentRegion.Offset(5, 0) = ""
.[A8].Resize(n, 7) = Brr
.[G4] = Now
End With
Set xD = Nothing: Erase Arr, Brr
End If
End Sub |
-
-
1.JPG
(175.87 KB)
|
