请教老师：用代码进行多表数据匹配汇总，谢谢！

hlly888

ak47ok 发表于 2015-9-4 10:55
谢谢老师提醒，重新上了仿真附件。麻烦老师再次指导，谢谢！

1. Sub yy() 'hlly888
   
2. Range("c2").Resize(90000, 13).ClearContents
   
3. Application.ScreenUpdating = False
   
4. Dim dc As Object, arr, i&, j%, x&, y%, sh As Worksheet
   
5. Set dc = CreateObject("scripting.dictionary")
   
6. yrr = Range("a2:a" & Range("a90000").End(3).Row)
   
7. ReDim brr(1 To 90000, 1 To 12)
   
8.    For i = 1 To UBound(yrr)
   
9.        dc(yrr(i, 1)) = i
   
10.    Next
    
11.    For Each sh In Worksheets
    
12.        If sh.Name <> "汇总" Then
    
13.           x = sh.Cells(Rows.Count, 28).End(xlUp).Row
    
14.           arr = sh.Range("ab10:al" & x)
    
15.           For i = 1 To UBound(arr)
    
16.               If dc.exists(arr(i, 1)) Then
    
17.                  For j = 2 To 11
    
18.                      brr(dc(arr(i, 1)), j - 1) = brr(dc(arr(i, 1)), j - 1) + arr(i, j)
    
19.                  Next
    
20.               End If
    
21.           Next
    
22.        End If
    
23.    Next
    
24. 
    
25. Range("c2").Resize(UBound(yrr), 11) = brr
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

hlly888

ak47ok 发表于 2015-9-4 10:55
谢谢老师提醒，重新上了仿真附件。麻烦老师再次指导，谢谢！

用代码汇总仿真.zip (501.77 KB, 下载次数: 24)

2015-9-4 11:33 上传

点击文件名下载附件

ak47ok

hlly888 发表于 2015-9-4 11:34

正解，运行速度很快，学习中，再次感谢老师！

zax010

Sub zz()
    Dim d, ar, br, i, j, m, s
    Set d = CreateObject("Scripting.Dictionary")
    ReDim br(1 To 300000, 1 To 12)
    Application.ScreenUpdating = False
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            ar = sh.Range("AB1:AL" & sh.Cells(sh.Cells.Rows.Count, "ab").End(3).Row)
            For i = 10 To UBound(ar)
                If ar(i, 1) <> "" Then
                    s = "" & ar(i, 1)
                    If d(s) = "" Then
                        m = m + 1: d(s) = m
                        br(m, 1) = s
                        For j = 3 To UBound(br, 2)
                            br(m, j) = ar(i, j - 1)
                        Next
                    Else
                        For j = 3 To UBound(br, 2)
                            br(d(s), j) = br(d(s), j) + ar(i, j - 1)
                        Next
                    End If
                End If
            Next
        End If
    Next
    Sheet3.Range("A2").Resize(m, 12) = br
    Application.ScreenUpdating = True
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>

用代码汇总仿真.rar (262.99 KB, 下载次数: 26)

2015-9-4 12:27 上传

点击文件名下载附件