[已解决]工作簿合并，并在第一列显示来源工作簿名称

stefdong

求助！先谢谢各位大神！
同一个文件夹有多个工作簿，每个工作簿中工作表的名称都一致，现需要将每个工作簿中的指定工作表复制到一个工作表中，并在第一列显示来源工作簿的名称。

以下是某大神的代码，但是只能合并，不能显示来源工作表名称：
Sub UnionWorksheets()
    Application.ScreenUpdating = False
    Dim lj As String
    Dim dirname As String
    Dim nm As String

    lj = ActiveWorkbook.Path
    nm = ActiveWorkbook.Name
    dirname = Dir(lj & "\*.xls*")

    Cells.Clear

    Do While dirname <> ""
        If dirname <> nm Then
            Workbooks.Open Filename:=lj & "\" & dirname

            Workbooks(nm).Activate

            '复制新打开工作簿的第一个工作表的已用区域到当前工作表
            Workbooks(dirname).Sheets(1).UsedRange.Copy _
                Range("A65536").End(xlUp).Offset(1, 0)

            Workbooks(dirname).Close False
        End If
        dirname = Dir
    Loop

End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-7-15 07:00

1. Sub UnionWorksheets()
   
2.     Application.ScreenUpdating = False
   
3.     Dim lj As String
   
4.     Dim dirname As String
   
5.     Dim nm As String
   
6.     With Application
   
7.         .ScreenUpdating = False
   
8.         .DisplayAlerts = False
   
9.         .EnableEvents = False
   
10.         .Calculation = xlCalculationManual
    
11.     End With
    
12. 
    
13. 
    
14.     lj = ActiveWorkbook.Path
    
15.     nm = ActiveWorkbook.Name
    
16.     dirname = Dir(lj & "\*.xls*")
    
17.    
    
18.     Cells.Clear
    
19. 
    
20.     Do While dirname <> ""
    
21.         If dirname <> nm Then
    
22.             Workbooks.Open Filename:=lj & "" & dirname
    
23.             
    
24.             Workbooks(nm).Activate
    
25.             
    
26.             '复制新打开工作簿的第一个工作表的已用区域到当前工作表
    
27.             Range("b65536").End(xlUp).Offset(1, -1).Value = dirname
    
28.             Workbooks(dirname).Sheets(1).UsedRange.Copy _
    
29.                     Range("b65536").End(xlUp).Offset(1, 0)
    
30.             Workbooks(dirname).Close False
    
31.         End If
    
32.         dirname = Dir
    
33.     Loop
    
34.    
    
35.     With Application
    
36.         .ScreenUpdating = True
    
37.         .DisplayAlerts = True
    
38.         .EnableEvents = True
    
39.         .Calculation = xlCalculationAutomatic
    
40.     End With
    
41.     MsgBox "合并完成"
    
42. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub UnionWorksheets()
   
2.     Application.ScreenUpdating = False
   
3.     Dim lj As String
   
4.     Dim dirname As String
   
5.     Dim nm As String
   
6. 
   
7.     lj = ActiveWorkbook.Path
   
8.     nm = ActiveWorkbook.Name
   
9.     dirname = Dir(lj & "\*.xls*")
   
10. 
    
11.     Cells.Clear
    
12. 
    
13.     Do While dirname <> ""
    
14.         If dirname <> nm Then
    
15.             Workbooks.Open Filename:=lj & "" & dirname
    
16. 
    
17.             Workbooks(nm).Activate
    
18. 
    
19.             '复制新打开工作簿的第一个工作表的已用区域到当前工作表
    
20.             Range("b65536").End(xlUp).Offset(1, -1).Value = dirname
    
21.             Workbooks(dirname).Sheets(1).UsedRange.Copy _
    
22.                     Range("b65536").End(xlUp).Offset(1, 0)
    
23. 
    
24.             Workbooks(dirname).Close False
    
25.         End If
    
26.         dirname = Dir
    
27.     Loop
    
28. 
    
29. End Sub

复制代码

hwc2ycy

1. Sub UnionWorksheets()
   
2.     Application.ScreenUpdating = False
   
3.     Dim lj As String
   
4.     Dim dirname As String
   
5.     Dim nm As String
   
6.     With Application
   
7.         .ScreenUpdating = False
   
8.         .DisplayAlerts = False
   
9.         .EnableEvents = False
   
10.         .Calculation = xlCalculationManual
    
11.     End With
    
12. 
    
13. 
    
14.     lj = ActiveWorkbook.Path
    
15.     nm = ActiveWorkbook.Name
    
16.     dirname = Dir(lj & "\*.xls*")
    
17.    
    
18.     Cells.Clear
    
19. 
    
20.     Do While dirname <> ""
    
21.         If dirname <> nm Then
    
22.             Workbooks.Open Filename:=lj & "" & dirname
    
23.             
    
24.             Workbooks(nm).Activate
    
25.             
    
26.             '复制新打开工作簿的第一个工作表的已用区域到当前工作表
    
27.             Range("b65536").End(xlUp).Offset(1, -1).Value = dirname
    
28.             Workbooks(dirname).Sheets(1).UsedRange.Copy _
    
29.                     Range("b65536").End(xlUp).Offset(1, 0)
    
30.             Workbooks(dirname).Close False
    
31.         End If
    
32.         dirname = Dir
    
33.     Loop
    
34.    
    
35.     With Application
    
36.         .ScreenUpdating = True
    
37.         .DisplayAlerts = True
    
38.         .EnableEvents = True
    
39.         .Calculation = xlCalculationAutomatic
    
40.     End With
    
41.     MsgBox "合并完成"
    
42. End Sub

复制代码

stefdong

hwc2ycy 发表于 2013-7-15 07:00

太感谢啦，已完美解决遇到的问题。以后工作轻松百倍啊！，大哥有什么VBA的书籍或或教程推荐吗，“兰色幻想VBA基础入门和高级开发全套80集视频教程，助你成为VBA开发高手。”这个视频教程你推荐吗？如果有视频还需要什么书籍配合学习吗？

hwc2ycy

stefdong 发表于 2013-7-15 18:13
太感谢啦，已完美解决遇到的问题。以后工作轻松百倍啊！，大哥有什么VBA的书籍或或教程推荐吗，“兰色 ...

校长的书和资料，你值得拥有。
问题解决了记得给最佳呀。

stefdong

hwc2ycy 发表于 2013-7-15 20:10
校长的书和资料，你值得拥有。
问题解决了记得给最佳呀。

已购买全套视频~学习中。
已给最佳答案~