|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant, cr As Variant
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("应付")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:c" & r)
End With
With Sheets("已付")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
br = .Range("a1:c" & r)
End With
With Sheets("未付")
ws = .Cells(Rows.Count, 1).End(xlUp).Row
cr = .Range("a1:c" & r)
End With
ReDim arr(1 To UBound(ar) + UBound(br), 1 To 5)
With Sheets("结果表")
dw = .[d1]
If dw = "" Then MsgBox "请选择供应商": End
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) = Trim(dw) Then
T = d(Trim(ar(i, 3)))
If T = "" Then
k = k + 1
d(Trim(ar(i, 3))) = k
T = k
arr(k, 1) = ar(i, 3)
End If
arr(T, 2) = arr(T, 2) + ar(i, 2)
End If
Next i
For i = 2 To UBound(br)
If Trim(br(i, 1)) = Trim(dw) Then
T = d(Trim(br(i, 2)))
If T = "" Then
k = k + 1
d(Trim(br(i, 2))) = k
T = k
arr(k, 1) = br(i, 2)
End If
arr(T, 3) = arr(T, 3) + br(i, 3)
arr(T, 5) = arr(T, 2) - arr(T, 3)
End If
Next i
For i = 2 To UBound(cr)
If Trim(cr(i, 1)) = Trim(dw) Then
T = d(Trim(cr(i, 2)))
If T = "" Then
k = k + 1
d(Trim(cr(i, 2))) = k
T = k
arr(k, 1) = cr(i, 2)
End If
arr(T, 4) = arr(T, 4) + cr(i, 3)
arr(T, 5) = arr(T, 2) - arr(T, 3)
End If
Next i
.[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(2) = Empty
.[a3].Resize(k, UBound(arr, 2)) = arr
.[a3].Resize(k, UBound(arr, 2)).Borders.LineStyle = 1
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|