多工作表汇总数据求助

kuangben8

如下图所示：多工作表汇总数据求助各位老师。感谢各位老师的围观和帮助。谢谢。


应询问者要求，附件已删除！感谢各位老师的帮助。



该贴已经同步到 kuangben8的微博

mineshine

仅供参考

1. 
   
2. Sub TT()
   
3.     Dim i%, d As Object
   
4.     Dim S As Worksheet, Sh As Worksheet
   
5.     Set S = Sheets("汇总")
   
6.     S.Columns("A:B").ClearContents  '清除汇总工作表A:B栏数据
   
7.     S.Cells(1, 1).Resize(, 2) = Array("上课地点(打印)", "当前人数") '在汇总工作表A1:B1写入表头
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     For Each Sh In Sheets
   
10.         If Sh.Name <> "汇总" Then
    
11.             arr = Sh.[A1].CurrentRegion
    
12.             For i = 2 To UBound(arr)
    
13.                 d(arr(i, 1)) = d(arr(i, 1)) + Val(arr(i, 9))
    
14.             Next i
    
15.         End If
    
16.     Next Sh
    
17.     Application.DisplayAlerts = False
    
18.     n = S.[A65536].End(xlUp).Row + 1
    
19.     S.Cells(n, 1).Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)   '上课地点(打印)
    
20.     S.Cells(n, 2).Resize(d.Count) = WorksheetFunction.Transpose(d.Items)     '当前人数
    
21.     Application.DisplayAlerts = True
    
22. End Sub
    

复制代码

lcjy11185

Private Sub CommandButton1_Click()
    Dim sh, r, c, arr, i
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 65532, 1 To 2)
    For Each sh In Sheets
        If sh.Name <> "汇总" Then
            arr = sh.[a1].CurrentRegion
            For i = 2 To UBound(arr)
                arr(i, 9) = val(arr(i, 9))
                s = arr(i, 1) & " " & arr(i, 5)
                r = d(s)
                If r = "" Then
                    m = m + 1
                    d(s) = m
                    brr(m, 1) = s
                    brr(m, 2) = arr(i, 9)
                Else
                    jb = d(s)
                    brr(jb, 1) = s
                    brr(jb, 2) = brr(jb, 2) + arr(i, 9)
                End If            
            Next
       End If
    Next
    k = d.keys
    it = d.items
    Rows("2:65536") = Empty
    [a2].Resize(m, 2) = brr
End Sub

kuangben8

mineshine 发表于 2013-8-15 16:44
仅供参考

目前发现很好使！感谢帮助！

kuangben8

lcjy11185 发表于 2013-8-15 17:07
Private Sub CommandButton1_Click()
    Dim sh, r, c, arr, i
    Set d = CreateObject("scripting.di ...

感谢帮助，但是运行错误啊？

lcjy11185

kuangben8 发表于 2013-8-15 17:10
目前发现很好使！感谢帮助！

有一句错了。见上面的代码
arr(i, 9) = arr(i, 9)*1
改为
arr(i, 9) = val(arr(i, 9))

lcjy11185

应要求，删除附件。不会被扣分吧

kuangben8

lcjy11185 发表于 2013-8-15 17:16
有一句错了。见上面的代码
arr(i, 9) = arr(i, 9)*1
改为

恩，谢谢，现在没问题了。