几个单独的文件要合并成一个表格，文件里均有2个sheet，并且表头有合并单元格

grayw

接我上个帖子的求助，上个求助帖为拆分表格。
几个文件要合并成一个文件（表头一致），这些单独文件的表头有合并单元格，同时每个表格有2个sheet，合并后的文件也为2个sheet。烦请大虾帮忙再看看，谢谢各位！

ykcbf1100

你那拆分的代码就是我写的。

附件供参考。。。

ykcbf1100

多工作簿多表按表名合并

1. Sub ykcbf()   '//2024.8.14   多工作簿多工作表合并
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     p = ThisWorkbook.Path & ""
   
9.     bm = [{"3原因","4离网"}]
   
10.     bt = [{2,3}]
    
11.     For x = 1 To UBound(bm)
    
12.         ws.Sheets(bm(x)).UsedRange.Clear
    
13.     Next
    
14.     For Each f In fso.GetFolder(p).Files
    
15.         If LCase$(f.Name) Like "*.xls*" Then
    
16.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
17.                 fn = fso.GetBaseName(f)
    
18.                 Set wb = Workbooks.Open(f, 0)
    
19.                 m = m + 1
    
20.                 For x = 1 To UBound(bm)
    
21.                     If m = 1 Then
    
22.                         wb.Sheets(bm(x)).UsedRange.Cells.Copy ws.Sheets(bm(x)).[a1]
    
23.                     Else
    
24.                         r = ws.Sheets(bm(x)).Cells(Rows.Count, 1).End(3).Row
    
25.                         wb.Sheets(bm(x)).UsedRange.Offset(bt(x)).Copy ws.Sheets(bm(x)).Cells(r + 1, 1)
    
26.                     End If
    
27.                 Next
    
28.                 wb.Close False
    
29.             End If
    
30.         End If
    
31.     Next f
    
32.     Application.ScreenUpdating = True
    
33.     Application.DisplayAlerts = True
    
34.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
35. End Sub
    

复制代码

grayw

ykcbf1100 发表于 2024-8-14 15:40
你那拆分的代码就是我写的。

附件供参考。。。

是的是的，大虾，万分感谢！！！