EXCEL多工作薄汇总求助

jjzzjc

各位大佬，我有几个部门做的预算表，我想把几个部门的数据表汇总到一张汇总表里请问怎样操作，谢谢了。

xiangbaoan

1. <div class="blockcode"><blockquote>Sub test1()
   
2.   Dim s As String, p As String, f As String
   
3.   Dim vResult(), vTemp, Conn As Object, rs As Object, Dic As Object, Dict As Object
   
4.   Dim Sht As Worksheet, Ran As Range, Cel As Range, m As Long, n As Long, i As Long, j As Long, k
   
5.   Dim strConn As String, subSQL As String, SQL As String, sFields As String, sTable As String
   
6.   
   
7.   DoApp False
   
8.   
   
9.   Set Conn = CreateObject("ADODB.Connection")
   
10.   'Set rs = CreateObject("ADODB.Recordset")
    
11.   
    
12.   s = "Excel 12.0;IMEX=1;HDR=yes;Database="
    
13.   If Application.Version < 12 Then
    
14.     s = Replace(s, "12.0", "8.0")
    
15.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
16.   Else
    
17.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
18.   End If
    
19.   
    
20.   Conn.Open strConn & ThisWorkbook.FullName
    
21.   
    
22.   p = ThisWorkbook.Path & Application.PathSeparator
    
23.   f = Dir(p & "*.xls?")
    
24.   
    
25.   While Len(f)
    
26.     If ThisWorkbook.FullName <> p & f Then _
    
27.       subSQL = subSQL & " UNION ALL SELECT [-sFields-] FROM [" & s & p & f & "].[[-sTable-]]"
    
28.     f = Dir
    
29.   Wend
    
30.   subSQL = Mid(subSQL, 12)
    
31.   
    
32.   Set Dic = CreateObject("Scripting.Dictionary")
    
33.   Set Dict = CreateObject("Scripting.Dictionary")
    
34.   
    
35.   For Each Sht In Worksheets
    
36.     With Sht
    
37.       If .Index > 3 Then
    
38.         Set Cel = .Range("A3")
    
39.         i = .Cells(.Rows.Count, "A").End(xlUp).Row 'Cel.End(xlDown).Row
    
40.         j = Cel.End(xlToRight).Column
    
41.         Set Ran = .Range(Cel, .Cells(i, j))
    
42.         For Each k In Ran
    
43.           If k.HasFormula Then Dict.Add k.Address(0, 0), k.FormulaR1C1
    
44.         Next
    
45.         vTemp = Ran.Value
    
46.         ReDim vResult(1 To UBound(vTemp) - 1, 1 To UBound(vTemp, 2) - 1)
    
47.         For i = 2 To UBound(vTemp)
    
48.           If Len(vTemp(i, 1)) Then Dic.Add vTemp(i, 1) & "|" & CStr(i - 2), i - 1
    
49.         Next
    
50.         k = UBound(vTemp) - 1
    
51.         sTable = .Name & "$" & Ran.Address(0, 0)
    
52.         sFields = "[" & vTemp(1, 1) & "]"
    
53.         For j = 2 To UBound(vTemp, 2)
    
54.           sFields = sFields & ",[" & vTemp(1, j) & "]"
    
55.         Next
    
56.         SQL = Replace(Replace(subSQL, "[-sFields-]", sFields), "[-sTable-]", sTable)
    
57.         SQL = "SELECT * FROM (" & SQL & ")"        ' ORDER BY " & vTemp(1, 1)
    
58.         'rs.Open SQL, Conn, 1, 3
    
59.         Set rs = Conn.Execute(SQL)
    
60.         vTemp = rs.GetRows
    
61.         'If rs.State = 1 Then rs.Close
    
62.         For n = 0 To UBound(vTemp, 2)
    
63.           If Not IsNull(vTemp(0, n)) Then
    
64.             If Dic.Exists(vTemp(0, n) & "|" & (n Mod k)) Then
    
65.               i = Dic(vTemp(0, n) & "|" & (n Mod k))
    
66.               For j = 1 To UBound(vTemp)
    
67.                 If Not IsNull(vTemp(j, n)) Then
    
68.                   If Val(vTemp(j, n)) Then
    
69.                     vResult(i, j) = Val(vResult(i, j)) + Val(vTemp(j, n))
    
70.                   Else
    
71.                     If IsEmpty(vResult(i, j)) Then vResult(i, j) = vTemp(j, n)
    
72.                   End If
    
73.                 End If
    
74.               Next
    
75.             End If
    
76.           End If
    
77.         Next
    
78.         Cel.Offset(1, 1).Resize(UBound(vResult), UBound(vResult, 2)) = vResult
    
79.         Erase vResult
    
80.         If Dict.Count Then
    
81.           For Each k In Dict.Keys
    
82.             .Range(k).FormulaR1C1 = Dict(k)
    
83.           Next
    
84.         End If
    
85.         m = m + 1
    
86.         Application.StatusBar = Space(88) & "完成 " & m & " / " & Worksheets.Count - 3 & " ，已处理： " & .Name
    
87.       End If
    
88.     End With
    
89.     Dic.RemoveAll
    
90.     Dict.RemoveAll
    
91.   Next
    
92.   Set rs = Nothing
    
93.   Conn.Close
    
94.   Set Conn = Nothing
    
95.   Set Cel = Nothing
    
96.   Set Ran = Nothing
    
97.   Set Sht = Nothing
    
98.   Set Dic = Nothing
    
99.   Set Dict = Nothing
    
100.   DoApp True
     
101. End Sub
     
102. 
     
103. Function DoApp(Optional b As Boolean = True)
     
104.   With Application
     
105.     .ScreenUpdating = b
     
106.     .DisplayAlerts = b
     
107.     .Calculation = -b * 30 - 4135
     
108.     If b Then .StatusBar = vbNullString: Beep
     
109.   End With
     
110. End Function

复制代码

xiangbaoan

修改仅供测试.rar (213.7 KB, 下载次数: 68)

2022-11-5 08:21 上传

点击文件名下载附件

青青草2018

用SUBTOTAL函数，求每张表中对应单元格的和

jjzzjc

xiangbaoan 发表于 2022-11-4 19:50

请问老师，这个是怎么设置的，我还有其他的表需要汇总，不止这三张明细表。

xiangbaoan

jjzzjc 发表于 2022-11-7 09:11
请问老师，这个是怎么设置的，我还有其他的表需要汇总，不止这三张明细表。

不超过49个应该都行。

jjzzjc

xiangbaoan 发表于 2022-11-7 09:58
不超过49个应该都行。

老师，我想修改一下两张表里的内容，我把所有表的格式和名称都改成一样的可以么？

xiangbaoan

jjzzjc 发表于 2022-11-10 17:55
老师，我想修改一下两张表里的内容，我把所有表的格式和名称都改成一样的可以么？

见附件再说吧……

jjzzjc

xiangbaoan 发表于 2022-11-10 17:57
见附件再说吧……

好的，老师，我先收集表格。谢谢