[已解决]多个工作簿按工作表名称合并数据

yewei113

大神们接客了
1、有很多个excel工作簿
2、按每个工作簿里的工作表名称相同的合并到新的工作簿里（工作表名称保持原来的）

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-10 18:40

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Set wb = ThisWorkbook
   
4. mypath = wb.Path & ""
   
5. wj = Dir(mypath & "*.xls*")
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. For Each m In wb.Sheets
   
9.     If m.Name <> "界面" Then m.Delete
   
10. Next
    
11. Do While wj <> ""
    
12.     If wj <> wb.Name Then
    
13.         With Workbooks.Open(mypath & wj)
    
14.             For Each m In .Sheets
    
15.                 Set sht = .Sheets(m.Name)
    
16.                 If wb.Sheets(m.Name) Is Nothing Then
    
17.                     sht.Copy after:=wb.Sheets(wb.Sheets.Count)
    
18.                 Else
    
19.                     n = wb.Sheets(m.Name).UsedRange.Rows.Count + 1
    
20.                     sht.Range("a1").CurrentRegion.Offset(1, 0).Copy wb.Sheets(m.Name).Cells(n, 1)
    
21.                 End If
    
22.             Next
    
23.             .Close 0
    
24.         End With
    
25.     End If
    
26.     wj = Dir
    
27. Loop
    
28. Application.DisplayAlerts = True
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Set wb = ThisWorkbook
   
4. mypath = wb.Path & ""
   
5. wj = Dir(mypath & "*.xls*")
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. For Each m In wb.Sheets
   
9.     If m.Name <> "界面" Then m.Delete
   
10. Next
    
11. Do While wj <> ""
    
12.     If wj <> wb.Name Then
    
13.         With Workbooks.Open(mypath & wj)
    
14.             For Each m In .Sheets
    
15.                 Set sht = .Sheets(m.Name)
    
16.                 If wb.Sheets(m.Name) Is Nothing Then
    
17.                     sht.Copy after:=wb.Sheets(wb.Sheets.Count)
    
18.                 Else
    
19.                     n = wb.Sheets(m.Name).UsedRange.Rows.Count + 1
    
20.                     sht.Range("a1").CurrentRegion.Offset(1, 0).Copy wb.Sheets(m.Name).Cells(n, 1)
    
21.                 End If
    
22.             Next
    
23.             .Close 0
    
24.         End With
    
25.     End If
    
26.     wj = Dir
    
27. Loop
    
28. Application.DisplayAlerts = True
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

cqcbc

dsmch 发表于 2016-5-10 18:40

不错，同时希望增加一列，记录来源于哪个工作簿。

防盗鼠

如果在C列加上每个工作薄的名字，该如何才做？谢谢。