按日期将两个工作表的数据汇总在一起

Qs18

试试...........

Qs18

试试..........

kort20034

Qs18 发表于 2024-11-5 15:42
试试..........

谢谢！字典看不太懂，如果增加条件，只汇总支付方式为线上的数据，应该在那里修改呀？

xsy我可以很好

kort20034 发表于 2024-11-5 17:16
谢谢！字典看不太懂，如果增加条件，只汇总支付方式为线上的数据，应该在那里修改呀？

最简单的方法是在楼上大师代码的基础上修改一句
dt = Format(arr(ii, 1), "yyyy/mm") & arr(ii, 3)

Qs18

kort20034 发表于 2024-11-5 17:16
谢谢！字典看不太懂，如果增加条件，只汇总支付方式为线上的数据，应该在那里修改呀？

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 20000, 1 To 3)
   
5. m = 1
   
6. a = [{"A支出","B支出"}]
   
7. For i = 1 To UBound(a)
   
8.     arr = Sheets(a(i)).UsedRange.Value
   
9.     For ii = 2 To UBound(arr)
   
10.     dt = Format(CDate(arr(ii, 1)), "yyyy/mm")
    
11.         If arr(ii, 3) = "线上" Then '在这里判断
    
12.             If Not dic.exists(dt) Then
    
13.                 m = m + 1
    
14.                 dic(dt) = m
    
15.                 brr(m, 1) = dt
    
16.                 If i = 1 Then brr(m, 2) = arr(ii, 2) Else brr(m, 3) = arr(ii, 2)
    
17.             Else
    
18.                 rw = dic(dt)
    
19.                 If i = 1 Then brr(rw, 2) = brr(rw, 2) + arr(ii, 2) Else brr(rw, 3) = brr(rw, 3) + arr(ii, 2)
    
20.             End If
    
21.         End If
    
22.     Next ii
    
23. Next
    
24. brr(1, 1) = "日期": brr(1, 2) = "A支出": brr(1, 3) = "B支出"
    
25. With Sheets("统计表")
    
26. .[b1].Resize(20000, 3) = Empty
    
27. .[b1].Resize(m - 1, 3) = brr
    
28. End With
    
29. Set dic = Nothing
    
30. End Sub
    

复制代码

Qs18

1. ‘加个判断
   
2. Sub qs()
   
3. Dim arr, i, dic
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To 20000, 1 To 3)
   
6. m = 1
   
7. a = [{"A支出","B支出"}]
   
8. For i = 1 To UBound(a)
   
9.     arr = Sheets(a(i)).UsedRange.Value
   
10.     For ii = 2 To UBound(arr)
    
11.     dt = Format(CDate(arr(ii, 1)), "yyyy/mm")
    
12.         If arr(ii, 3) = "线上" Then '在这里判断
    
13.             If Not dic.exists(dt) Then
    
14.                 m = m + 1
    
15.                 dic(dt) = m
    
16.                 brr(m, 1) = dt
    
17.                 If i = 1 Then brr(m, 2) = arr(ii, 2) Else brr(m, 3) = arr(ii, 2)
    
18.             Else
    
19.                 rw = dic(dt)
    
20.                 If i = 1 Then brr(rw, 2) = brr(rw, 2) + arr(ii, 2) Else brr(rw, 3) = brr(rw, 3) + arr(ii, 2)
    
21.             End If
    
22.         End If
    
23.     Next ii
    
24. Next
    
25. brr(1, 1) = "日期": brr(1, 2) = "A支出": brr(1, 3) = "B支出"
    
26. With Sheets("统计表")
    
27. .[b1].Resize(20000, 3) = Empty
    
28. .[b1].Resize(m - 1, 3) = brr
    
29. End With
    
30. Set dic = Nothing
    
31. End Sub
    

复制代码

yanglinzi

请测试。。

kort20034

yanglinzi 发表于 2024-11-5 20:35
请测试。。

对我来说，你的代码比较友善

翁知江安

Sub 汇总统计()
Dim i, j, k, irow1, m, n, kk, item
Dim arr, teparr, crr
Dim sht As Worksheet
Dim a As Date
a = Time
Dim d1 As Object
Dim d2 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("统计表").Range("h1:j100").Clear
Sheets("统计表").Cells(1, 8) = "日期"
Sheets("统计表").Cells(1, 9) = "A支出"
Sheets("统计表").Cells(1, 10) = "B支出"

ReDim arr(1 To 500, 1 To 4)
For Each sht In Worksheets
   If sht.Name <> "统计表" Then
   j = j + 1
   teparr = sht.[a1].CurrentRegion
   irow1 = sht.[a65536].End(xlUp).Row
   For n = 2 To irow1
     For m = 1 To 2
     arr(n - 1, m + 2 * j - 2) = teparr(n, m)
     Next
   Next
   End If
Next

For k = 1 To UBound(arr)
  If arr(k, 1) <> "" Then
  d1(arr(k, 1)) = d1(arr(k, 1)) + arr(k, 2)
  End If
  If arr(k, 3) <> "" Then
  d2(arr(k, 3)) = d2(arr(k, 3)) + arr(k, 4)
  End If
Next

ReDim crr(1 To d1.Count + d2.Count, 1 To 2)
For Each kk In d2.keys
  If Not d1.exists(kk) Then
    d1(kk) = "" & "," & d2(kk)
    Else
    d1(kk) = d1(kk) & "," & d2(kk)
   End If
Next
ReDim crr(1 To d1.Count, 1 To 2)
For Each item In d1.items
   i = i + 1
   If InStr(item, ",") >= 1 Then
   crr(i, 1) = Split(item, ",")(0)
   crr(i, 2) = Split(item, ",")(1)
   Else
   crr(i, 1) = item
   crr(i, 2) = ""
   End If
Next
With Sheets("统计表")
  .[h2].Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.keys)
  .[i2].Resize(UBound(crr), UBound(crr, 2)) = crr
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
MsgBox Time - a
End Sub

翁知江安