多表按条件汇总

chbb6666

函数已实现，但速度太慢，请能人VBA实现下

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.4
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("汇总1-12")
   
7.     On Error Resume Next
   
8.     For Each sht In Sheets
   
9.         With sht
   
10.             If .UsedRange.Count > 1 Then
    
11.                 arr = .UsedRange
    
12.                 For j = 1 To UBound(arr, 2)
    
13.                     If arr(i, 1) <> Empty Then
    
14.                         s = arr(1, j)
    
15.                         d1(s) = s
    
16.                     End If
    
17.                 Next
    
18.                 For i = 2 To UBound(arr)
    
19.                     s = arr(i, 2)
    
20.                     If s <> Empty Then
    
21.                         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
22.                         For j = 1 To UBound(arr, 2)
    
23.                             ss = arr(1, j)
    
24.                             d(s)(ss) = d(s)(ss) + arr(i, j)
    
25.                         Next
    
26.                     End If
    
27.                 Next
    
28.             End If
    
29.         End With
    
30.     Next
    
31.     ReDim zrr(1 To d.Count, 1 To 2)
    
32.     For Each k In d.keys
    
33.         n = n + 1
    
34.         zrr(n, 1) = n
    
35.         zrr(n, 2) = k
    
36.     Next
    
37.     With sh
    
38.         .UsedRange = ""
    
39.         .[a1].Resize(1, d1.Count) = d1.keys
    
40.         .[a2].Resize(n, 2) = zrr
    
41.         arr = .UsedRange
    
42.         For i = 2 To UBound(arr)
    
43.             If arr(i, 1) <> Empty Then
    
44.                 For j = 3 To UBound(arr, 2)
    
45.                     If d.exists(arr(i, 2)) Then
    
46.                         arr(i, j) = d(arr(i, 2))(arr(1, j))
    
47.                     End If
    
48.                 Next
    
49.             End If
    
50.         Next
    
51.         .UsedRange = arr
    
52.         ActiveWindow.DisplayZeros = False
    
53.     End With
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "OK！"
    
56. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

sunshuangzhong

Sub test4444()'说明：每个表必须有数据，不能是空工作表
Dim sht As Worksheet, ar(), m, erow
For Each sht In Sheets
    With sht
        If .Name <> "汇总1-12" And .Visible = -1 Then
            erow = .Range("b65536").End(3).Row
            m = m + 1: ReDim Preserve ar(1 To m)
            ar(m) = .Name & "!" & .Range("b1:n" & erow).Address(ReferenceStyle:=xlR1C1)
        End If
    End With
Next
    With Sheets("汇总1-12").Range("a1")
        .CurrentRegion.ClearContents
        .Value = "姓名"
        .Consolidate Sources:=ar, Function:=xlSum, TopRow:=True, LeftColumn:=True
    End With
End Sub

chbb6666

ykcbf1100 发表于 2024-1-4 14:58
附件供参考。。。

谢谢，差了一点，就是把合计表格也汇总起来了，多次点汇总累加。

ykcbf1100

chbb6666 发表于 2024-1-4 16:52
谢谢，差了一点，就是把合计表格也汇总起来了，多次点汇总累加。

你的附件可没有总表汇总的，是你临时想起来的吧。

his803

在@ykcbf1100 老师的基础上，添加一句if语句进行既定就可以了。

his803

向ykcbf1100老师学习！

his803

ykcbf1100

不知道有没有满足楼主的需求。

kittli

试一下！!!!!