不同工作表相同内容合并

xuxinjie1993 · 发表于 2022-9-20 10:05

各位大神由于每个区域每天都动态的在共享链接内填报数据，如果每次需要数据的时候都手动去粘贴在一起比较麻烦，其实每个区县填报得数据其实是相同格式，我想实时得把各个子表数据合并在表内，方便在一个总表就把所有数据看了。麻烦各位大神赐教，顺便展示一下代码方便学习变通。

xuxinjie1993 · 发表于 2022-9-20 10:08

后续可能会新增子表，但同步其他区域也会增加，所有请各位大神展示下代码，方便后续修改，谢谢、谢谢、谢谢、谢谢

xiangbaoan · 发表于 2022-9-20 12:13

Sub test1() '根据提供的工作表一次性汇总，有就汇总。另外，此法要求工作簿不超过49个,同名工作表格式一致。若超49个工作簿得另写。
Dim Conn As Object, rs As Object, Cata As Object, tb As Object, Dict As Object
Dim p As String, f As String, strConn As String, s As String, t As String
Dim j As Long, k, Sht As Worksheet
Set Dict = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each Sht In Worksheets
With Sht
.Cells.Clear 'Contents
Dict.Add .Name & "$", vbNullString
End With
Next
s = "Excel 12.0;HDR=yes;Database="
If Application.Version < 12 Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source="
End If
Set Cata = CreateObject("ADOX.Catalog")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do
If f <> ThisWorkbook.Name Then
Cata.ActiveConnection = strConn & p & f
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", "")
If Right(t, 1) = "$" Then
If Dict.Exists(t) Then Dict(t) = Dict(t) & " UNION ALL SELECT * FROM [" & s & p & f & "].[" & t & "] WHERE 区域 IS NOT NULL"
End If
End If
Next
'Cata.ActiveConnection = Nothing
End If
f = Dir
Loop While f <> ""
Set tb = Nothing
Set Cata = Nothing
Set Conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
Conn.Open strConn & ThisWorkbook.FullName
For Each k In Dict.Keys
rs.Open Mid(Dict(k), 12), Conn, 1, 3
With Worksheets(Replace(k, "$", ""))
For j = 0 To rs.Fields.Count - 1
.Range("A1").Offset(0, j) = rs.Fields(j).Name
Next
.Range("A" & .Rows.Count).End(xlUp).Offset(1).CopyFromRecordset rs
End With
If rs.State = 1 Then rs.Close
Next
Set rs = Nothing
Conn.Close
Set Conn = Nothing
Set Dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

xiangbaoan · 发表于 2022-9-20 12:14

测试.rar (147.39 KB, 下载次数: 7)

xuxinjie1993 · 发表于 2022-9-20 12:43

xiangbaoan 发表于 2022-9-20 12:14

谢谢，麻烦给下代码，后续如果新增子表如何操作呢

xiangbaoan · 发表于 2022-9-20 17:27

xuxinjie1993 发表于 2022-9-20 12:43
谢谢，麻烦给下代码，后续如果新增子表如何操作呢

若只是汇总其它的工作表，只需在汇总工作簿中增加工作表名。

我对你新增子表理解为增加工作簿数量.rar (152.82 KB, 下载次数: 2)

		自动登录	找回密码
密码			免费注册

[求助] 不同工作表相同内容合并

评分