怎么将多个表格内容合并到一张表？

一粒粒

1、子表1为广州区域的三种类型文件，子表2为深圳区域的三种类型文件，现在要用一张新表，将这三种类型的广州、深圳内容汇总到一起；
2、每张表的第一行内容不一定一致，需要实现如果合并的第一列内容不一致，可以继续在第一行平铺内容（比如两张子表的YDsheet页）；
3、序号是唯一的，不管合并多少条数据，每行都是从1到最后按顺序排列
具体内容看附件，求求各位大神怎么用VBA解决，如果函数可以解决我也洗耳恭听

LIUZHU

JSA代码参与下

1. function 汇总(){
   
2.         let fname=Dir(`${ThisWorkbook.Path}\\子表*.xls*`);
   
3.         let obj={};
   
4.         while(fname!=""){
   
5.                 Workbooks.Open(`${ThisWorkbook.Path}\\${fname}`);
   
6.                 [...Sheets].forEach(sh=>{
   
7.                         let arr=sh.Range("a1").CurrentRegion.Value2;
   
8.                         let temp1=obj[sh.Name]=obj[sh.Name] || [[]];
   
9.                         temp1[0]=[...new Set([...temp1[0],...arr[0]])];                //表头更新
   
10.                         arr.slice(1).forEach(x=>{
    
11.                                 let temp2=temp1[temp1.length]=[];
    
12.                                 arr[0].forEach((y,i)=>temp2[temp1[0].indexOf(y)]=x[i]);
    
13.                                 temp2[0]=temp1.length-1;                //序号
    
14.                         });
    
15.                 });
    
16.                 ActiveWorkbook.Close(false);
    
17.                 fname=Dir();
    
18.         }
    
19.         [Application.DisplayAlerts,Application.ScreenUpdating]=[false,false];
    
20.         for (let key in obj){
    
21.                 try{Sheets.Item(key).Delete()}catch{};
    
22.                 Sheets.Add(null,Sheets.Item(Sheets.Count)).Name=key;
    
23.                 let temp=obj[key];
    
24.                 Range("a1").Resize(temp.length,temp[0].length).Value2=temp;
    
25.         }
    
26.         [Application.DisplayAlerts,Application.ScreenUpdating]=[true,true];
    
27. }

复制代码

cnmlgb9998

PQ吧，除了不能拆表！！！！！！！！！！！！

LIUZHU

cnmlgb9998 发表于 2024-3-25 16:24
PQ吧，除了不能拆表！！！！！！！！！！！！

看起来挺厉害的

ykcbf1100

附件供参考。。。

LIUZHU

附件，请用WPS测试

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.25
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Dim fns As New Collection
   
5.     Application.ScreenUpdating = False
   
6.     p = ThisWorkbook.Path & ""
   
7.     Set ws = ThisWorkbook
   
8.     For Each sht In ws.Sheets
   
9.         With sht
   
10.             fns.Add .Name
    
11.             .UsedRange.Offset(1).ClearContents
    
12.         End With
    
13.     Next
    
14.     On Error Resume Next
    
15.     For Each k In fns
    
16.         d.RemoveAll
    
17.         Set sht = ws.Sheets(k)
    
18.         arr = sht.UsedRange
    
19.         For j = 1 To UBound(arr, 2)
    
20.             s = arr(1, j)
    
21.             d(s) = j
    
22.         Next
    
23.         m = 0
    
24.         ReDim brr(1 To 10000, 1 To d.Count)
    
25.         For Each f In fso.GetFolder(p).Files
    
26.             If f.Name Like "*.xls*" Then
    
27.                 If InStr(f.Name, ws.Name) = 0 Then
    
28.                     fn = fso.GetBaseName(f)
    
29.                     Set wb = Workbooks.Open(f, 0)
    
30.                     With wb.Sheets(1)
    
31.                         arr = .UsedRange
    
32.                         wb.Close False
    
33.                     End With
    
34.                     For i = 2 To UBound(arr)
    
35.                         m = m + 1
    
36.                         For j = 1 To UBound(arr, 2)
    
37.                             s = arr(1, j)
    
38.                             If d.exists(s) Then
    
39.                                 brr(m, d(s)) = arr(i, j)
    
40.                             End If
    
41.                         Next
    
42.                     Next
    
43.                 End If
    
44.             End If
    
45.         Next f
    
46.         sht.[a2].Resize(m, d.Count) = brr
    
47.         sht.[a2].Resize(m, d.Count).Borders.LineStyle = 1
    
48.     Next
    
49.     Set d = Nothing
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    
53. 
    

复制代码

jjmysjg

按表名合并工作簿

hhxq001

试一试这个方便不，可以自由选择导入的分表


汇总（成果文件-试一试.rar (40.35 KB, 下载次数: 11)

2024-3-27 16:17 上传

点击文件名下载附件

fzxba

1. Sub test1() '练习
   
2.   
   
3.   Dim Conn As Object, rs As Object, Cata As Object, tb As Object, Dic As Object, Dict As Object
   
4.   Dim p As String, f As String, strConn As String, SQL As String, Field As String, s As String, t As String
   
5.   Dim ar, i As Long, vrtKey, wks As Worksheet
   
6.   
   
7.   Set Dic = CreateObject("Scripting.Dictionary")
   
8.   
   
9.   For Each wks In Worksheets
   
10.     With wks
    
11.       .Cells.ClearContents
    
12.       .UsedRange.Borders.LineStyle = xlNone
    
13.       Set Dic(.Name & "$") = CreateObject("Scripting.Dictionary")
    
14.     End With
    
15.   Next
    
16.   
    
17.   Application.ScreenUpdating = False
    
18.   
    
19.   Set Dict = CreateObject("Scripting.Dictionary")
    
20.   Set Conn = CreateObject("ADODB.Connection")
    
21.   Set rs = CreateObject("ADODB.Recordset")
    
22.   Set Cata = CreateObject("ADOX.Catalog")
    
23.   
    
24.   s = "Excel 12.0;HDR=YES;Database="
    
25.   If Application.Version < 12 Then
    
26.     s = Replace(s, "12.0", "8.0")
    
27.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
28.   Else
    
29.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
30.   End If
    
31.   Conn.Open strConn & ThisWorkbook.FullName
    
32.   
    
33.   p = ThisWorkbook.Path & "\"
    
34.   f = Dir(p & "*.xls*")
    
35.   Do
    
36.     If p & f <> ThisWorkbook.FullName Then
    
37.       Cata.ActiveConnection = strConn & p & f
    
38.       For Each tb In Cata.Tables
    
39.         If tb.Type = "TABLE" Then
    
40.           t = Replace(tb.Name, "'", vbNullString)
    
41.           If Right(t, 1) = "$" Then
    
42.             SQL = "SELECT * FROM [" & s & p & f & "].[" & t & "A1:Z1] WHERE FALSE"
    
43.             Set rs = Conn.Execute(SQL)
    
44.             For i = 0 To rs.Fields.Count - 1
    
45.               Field = rs.Fields(i).Name
    
46.               If Not Field Like "F[1-9]*" Then
    
47.                 Field = "`" & Field & "`"
    
48.                 If Not Dic(t).Exists(Field) Then Dic(t).Add Field, Dic(t).Count
    
49.               End If
    
50.             Next
    
51.           End If
    
52.         End If
    
53.       Next
    
54.     End If
    
55.     f = Dir
    
56.   Loop While f <> ""
    
57.   
    
58.   f = Dir(p & "*.xls*")
    
59.   Do
    
60.     If p & f <> ThisWorkbook.FullName Then
    
61.       Cata.ActiveConnection = strConn & p & f
    
62.       For Each tb In Cata.Tables
    
63.         If tb.Type = "TABLE" Then
    
64.           t = Replace(tb.Name, "'", vbNullString)
    
65.           If Right(t, 1) = "$" Then
    
66.             ar = Dic(t).Keys
    
67.             For i = 0 To UBound(ar)
    
68.               ar(i) = "NULL AS " & ar(i)
    
69.             Next
    
70.             SQL = "SELECT * FROM [" & s & p & f & "].[" & t & "A1:Z1] WHERE FALSE"
    
71.             Set rs = Conn.Execute(SQL)
    
72.             For i = 0 To rs.Fields.Count - 1
    
73.               Field = "`" & rs.Fields(i).Name & "`"
    
74.               ar(Dic(t)(Field)) = Field
    
75.             Next
    
76.             SQL = " UNION ALL SELECT " & Join(ar, ",") & " FROM [" & s & p & f & "].[" & t & "A1:Z] WHERE 序号 IS NOT NULL"
    
77.             Dict(t) = Dict(t) & SQL
    
78.           End If
    
79.         End If
    
80.       Next
    
81.     End If
    
82.     f = Dir
    
83.   Loop While f <> ""
    
84.   Set Cata = Nothing
    
85.   
    
86.   For Each vrtKey In Dict.Keys
    
87.     If rs.State = 1 Then rs.Close
    
88.     rs.Open Mid(Dict(vrtKey), 12), Conn, 1, 3
    
89.     With Worksheets(Replace(vrtKey, "$", vbNullString)).Range("A1")
    
90.       For i = 0 To rs.Fields.Count - 1
    
91.         .Offset(0, i) = rs.Fields(i).Name
    
92.       Next
    
93.       .Offset(1).CopyFromRecordset rs
    
94.       With .CurrentRegion
    
95.         .Borders.LineStyle = xlContinuous
    
96.         ar = .Columns(1)
    
97.         For i = 2 To UBound(ar)
    
98.           ar(i, 1) = i - 1
    
99.         Next
    
100.         .Columns(1) = ar
     
101.       End With
     
102.     End With
     
103.   Next
     
104.   
     
105.   If rs.State = 1 Then rs.Close
     
106.   Set rs = Nothing
     
107.   Conn.Close
     
108.   Set Conn = Nothing
     
109.   Set Dic = Nothing
     
110.   Set Dict = Nothing
     
111.   
     
112.   Application.ScreenUpdating = True
     
113.   Beep
     
114. End Sub

复制代码