多条件汇总

tonytg

请教各位，如附件所示，如何使用VBA实现将多张分表数据根据条件汇总到汇总表呢？谢谢！

A1233515

附件供参考

笨鸟飞不高

多条件汇总.zip (23.6 KB, 下载次数: 19)

2021-7-22 12:35 上传

点击文件名下载附件

参考！

tonytg

非常感谢2楼3楼两位高手的帮助！两个程序运行都是正确的，3楼的还需略作改进，文本数字不需要统计到汇总表。

tonytg

是我在求助文字中没说明清楚。

65861954

凭自己理解写了一个，感觉有点繁琐。凑个数。下载大佬们的来学习学习，

lsc900707

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     For Each sht In Sheets
   
4.         If sht.Name <> ActiveSheet.Name Then
   
5.             With sht
   
6.                 arr = .[a1].CurrentRegion
   
7.                 For i = 3 To UBound(arr)
   
8.                     s = Trim(arr(i, 1) & arr(i, 2) & arr(i, 7))
   
9.                     If Not d.exists(s) Then
   
10.                         d(s) = arr(i, 5)
    
11.                     Else
    
12.                         d(s) = d(s) + arr(i, 5)
    
13.                     End If
    
14.                 Next
    
15.             End With
    
16.         End If
    
17.     Next
    
18.     brr = [a1].CurrentRegion
    
19.     For i = 2 To UBound(brr): Sum = 0
    
20.         For j = 4 To UBound(brr, 2)
    
21.             s = Trim(brr(i, 1) & brr(i, 2) & brr(1, j))
    
22.             brr(i, j) = d(s)
    
23.             Sum = Sum + brr(i, j)
    
24.         Next
    
25.         brr(i, 3) = Sum
    
26.     Next
    
27.     [a1].CurrentRegion = brr
    
28. End Sub

复制代码

lsc900707

测试参考附件：

笨鸟飞不高

tonytg 发表于 2021-7-22 17:23
非常感谢2楼3楼两位高手的帮助！两个程序运行都是正确的，3楼的还需略作改进，文本数字不需要统计到汇总表 ...

不是你没说清楚，是我没仔细看数据源！！

Sub AwTest()
    Dim i&, c%, x&, r&, rqmc$, arr, brr(1 To 5000, 1 To 5), ws As Worksheet, d As Object
    Set d = CreateObject("Scripting.Dictionary")
    Sheet1.Activate
    For Each ws In Sheets
        If ws.Name <> ActiveSheet.Name Then
            arr = ws.Range("A3:G" & ws.Cells(Rows.Count, 1).End(3).Row)
            For i = 1 To UBound(arr)
                If arr(i, 7) = "A公司" Then
                    c = 4
                ElseIf arr(i, 7) = "B公司" Then
                    c = 5
                Else
                    GoTo line:
                End If
                rqmc = arr(i, 1) & "|" & arr(i, 2)
                x = d(rqmc)
                If x = 0 Then r = r + 1: d(rqmc) = r: brr(r, 1) = arr(i, 1): brr(r, 2) = arr(i, 2): x = r
                brr(x, c) = brr(x, c) + arr(i, 5)
                brr(x, 3) = brr(x, 4) + brr(x, 5)
line:
            Next
        End If
    Next
    If r > 0 Then
        [2:5000].ClearContents
        [a2].Resize(r, 5) = brr
        [a1].CurrentRegion.Sort key1:=[a1], order1:=1, key2:=[b1], order2:=1, Header:=xlYes
    End If
End Sub

tonytg

lsc900707 发表于 2021-7-22 20:58
测试参考附件：

很好用，这段代码简单明了，非常感谢！