如何将多个工作簿的多个excel表格移动到一个工作簿中

郭柏慧

zhaogang1960 发表于 2015-6-1 18:45
下面附件中有2003、2007格式：

大神  可以请教一个具体问题吗，我的问题跟您回答这个很像

郭柏慧

zhaogang1960 发表于 2015-6-1 18:45
下面附件中有2003、2007格式：

大神 可以清缴个具体问题吗  

郭柏慧

zhaogang1960 发表于 2015-6-1 18:45
下面附件中有2003、2007格式：

老师您好，您看这个问题可以解决吗。
如何将多个工作簿的多个excel表格移动到一个工作簿中
https://club.excelhome.net/thread-1606643-1-1.html

ykcbf1100

多文件单表合并成单文件多表

ykcbf1100

1. Sub ykcbf()  '//2025.3.17
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set ws = ThisWorkbook
   
7.     For Each sh In ws.Sheets
   
8.         If sh.Name <> ActiveSheet.Name Then sh.Delete
   
9.     Next
   
10.     On Error Resume Next
    
11.     For Each f In fso.GetFolder(p).Files
    
12.         If LCase$(f.Name) Like "*.xls*" Then
    
13.             If InStr(f.Name, ws.Name) = 0 Then
    
14.                 m = m + 1
    
15.                 Set wb = Workbooks.Open(f, 0)
    
16.                 fn = fso.GetBaseName(f)
    
17.                 If m = 1 Then
    
18.                     Set sh = ws.Sheets(1)
    
19.                     wb.Sheets(1).Cells.Copy sh.[a1]
    
20.                     sh.Name = fn
    
21.                 Else
    
22.                     wb.Sheets(1).Copy After:=ws.Sheets(ws.Sheets.Count)
    
23.                     ws.Sheets(ws.Sheets.Count).Name = fn
    
24.                 End If
    
25.                 wb.Close 0
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     sh.Activate
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "ok"
    
32. End Sub
    

复制代码

ＥＸＣＥＬ小子

1. Sub ProcessWorkbooks()
   
2.     Dim fd As FileDialog
   
3.     Dim selectedFolder As String
   
4.     Dim fileName As String
   
5.     Dim srcWorkbook As Workbook
   
6.    
   
7.     Dim anyCopied As Boolean
   
8.    
   
9.     ' 初始化标志
   
10.     anyCopied = False
    
11.    
    
12.     ' 优化执行
    
13.     Application.ScreenUpdating = False
    
14.     Application.DisplayAlerts = False
    
15.    
    
16.    
    
17.    
    
18.     ' 步骤1：选择文件夹对话框
    
19.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
20.     With fd
    
21.         .Title = "请选择包含Excel文件的文件夹"
    
22.         If .Show = -1 Then
    
23.             selectedFolder = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "", "", "")
    
24.              ' 步骤2：删除所有原始工作表（保留临时工作表）
    
25.    
    
26.                 Do While ThisWorkbook.Worksheets.Count > 1
    
27.                     ThisWorkbook.Worksheets(1).Delete
    
28.                 Loop
    
29.         Else
    
30.             MsgBox "未选择文件夹，操作已取消。"
    
31.             GoTo CleanUp
    
32.         End If
    
33.     End With
    
34.    
    
35.     ' 步骤3：遍历并处理Excel文件
    
36.     fileName = Dir(selectedFolder & "*.xls*")
    
37.     Do While fileName <> ""
    
38.         ' 跳过临时文件
    
39.         If Left(fileName, 2) <> "~$" Then
    
40.             On Error Resume Next
    
41.             Set srcWorkbook = Workbooks.Open(selectedFolder & fileName, ReadOnly:=True)
    
42.             
    
43.             If Not srcWorkbook Is Nothing Then
    
44.                 ' 复制"表1"（按名称匹配）
    
45.                 On Error GoTo 0
    
46.                
    
47.                     srcWorkbook.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
48.                     anyCopied = True
    
49.                 srcWorkbook.Close False
    
50.             End If
    
51.         End If
    
52.         fileName = Dir()
    
53.     Loop
    
54.    
    
55. 
    
56.     ' 清理临时工作表
    
57.     If anyCopied Then
    
58.         Application.DisplayAlerts = False
    
59.         ThisWorkbook.Worksheets(1).Delete
    
60.         Application.DisplayAlerts = True
    
61.    
    
62.     End If
    
63.     MsgBox "处理完成！共合并 " & ThisWorkbook.Worksheets.Count & " 个工作表"
    
64. CleanUp:
    
65.     ' 恢复设置
    
66.     Application.ScreenUpdating = True
    
67.     Application.DisplayAlerts = True
    
68.    
    
69. End Sub
    
70. 
    
71. 
    

复制代码