|
发表于 2016-1-20 10:19
|
显示全部楼层
本楼为最佳答案
- Sub 汇总()
- Set d = CreateObject("scripting.dictionary")
- rq1 = [b1]: rq2 = [d1] '起止日期
- Dim brr(1 To 10000, 1 To 5)
- With Sheets("回款付款")
- arr = .Range("a1:ab" & .UsedRange.Rows.Count)
- For j = 3 To 17 Step 14 'j=3 或 17
- For i = 8 To UBound(arr)
- If Len(arr(i, j)) > 0 Then
- rq = arr(i, j)
- x = arr(i, j + 5)
- If Not d.Exists(x) Then
- n = n + 1: d(x) = n
- brr(n, 1) = x
- End If
- p = d(x)
- If rq < rq1 Then '日期在指定日期之前,期初值
- k = IIf(j = 3, 2, 3) 'j=3,借方,否则贷方
- brr(p, k) = brr(p, k) + arr(i, j + 6)
- ElseIf rq <= rq2 Then '日期在指定日期之间,本期值
- k = IIf(j = 3, 4, 5) 'j=3,借方,否则贷方
- brr(p, k) = brr(p, k) + arr(i, j + 6)
- End If
- End If
- Next
- Next
- End With
-
- With Sheets("费用收支")
- arr = .Range("a1:m" & .UsedRange.Rows.Count)
- For i = 8 To UBound(arr)
- If Len(arr(i, 6)) > 0 Then
- rq = arr(i, 6)
- x = arr(i, 8)
- If Not d.Exists(x) Then
- n = n + 1: d(x) = n
- brr(n, 1) = x
- End If
- p = d(x)
- If rq < rq1 Then '日期在指定日期之前,期初值
- brr(p, 2) = brr(p, 2) + arr(i, 12)
- brr(p, 3) = brr(p, 3) + arr(i, 13)
- ElseIf rq <= rq2 Then '日期在指定日期之间,本期值
- brr(p, 4) = brr(p, 4) + arr(i, 12)
- brr(p, 5) = brr(p, 5) + arr(i, 13)
- End If
- End If
- Next
- End With
- [a8:e10000].ClearContents
- If n > 0 Then [a8].Resize(n, 5) = brr
- End Sub
复制代码 |
|