[已解决]合并工作簿，再合并到一个工作表。

daniel32

1.合并选定的工作簿里的工作表到一个新工作簿
2.新工作簿里的工作表内容合并到一个工作表里面
请见附件，在网上找了一个能做第一步的，请教完整代码，谢谢。

最佳答案

月排行榜 / 总排行榜

冥王

2014-5-14 17:49

1. Sub demo()
   
2.     UsedRange.Rows.Delete   '''''''''''''''''''''''''''''''''''''先清除工作表里面不需要的内容
   
3.     Dim p As String, f As String
   
4.     Dim s As Worksheet
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         .Title = "请选定要汇总的文件所在目录"
   
7.         .Show
   
8.         If .SelectedItems.Count = 0 Then Exit Sub
   
9.         p = .SelectedItems(1) & ""
   
10.     End With
    
11.     Application.ScreenUpdating = False
    
12.     f = Dir(p & "*.xls")
    
13.     Do While f <> ""
    
14.         Set w = Workbooks.Open(p & f)
    
15.         For Each s In w.Sheets
    
16.             s.UsedRange.Copy ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Offset(1, 0)
    
17.         Next
    
18.         w.Close False
    
19.         f = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

开心妙妙

合并工作簿再合并到一个工作表.rar (26.95 KB, 下载次数: 8)

2014-5-14 17:11 上传

点击文件名下载附件

1. Sub 合并()
   
2.     Application.ScreenUpdating = False
   
3.     Dim lj$, dirname$, nm$, i%
   
4.     lj = ActiveWorkbook.Path    '激活工作簿路径
   
5.     nm = ActiveWorkbook.Name  '激活工作簿名称
   
6.     dirname = Dir(lj & "\*.xls*")    '用DIR取得工作表名
   
7.     Cells.Clear              '删除数据
   
8.     Do While dirname <> ""   '工作簿名<>空，就循环
   
9.         If dirname <> nm Then  '如果工作表簿<>激活工作簿名
   
10.             Workbooks.Open Filename:=lj & "" & dirname  '打开DIR找到的工作簿
    
11.             i = Workbooks(dirname).Sheets("Sheet1").Range("A65536").End(xlUp).Row
    
12.             Sheets("Sheet1").Activate
    
13.             Workbooks(nm).Activate
    
14.             Workbooks(dirname).Sheets("Sheet1").Range("A1:C" & i).Copy Range("A65536").End(xlUp).Offset(1, 0)
    
15.             Workbooks(dirname).Close False
    
16.         End If
    
17.         dirname = Dir
    
18.     Loop
    
19.     Columns("A:C").EntireColumn.AutoFit    '最适合列宽
    
20.     Rows("1:1").Delete
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

daniel32

谢谢，上面的代码只能合并工作簿里的一个工作表，如果不只一个工作表有数据不能合并，而且只能针对当前文件夹，我想要可以自选不同文件做合并，就像样式那样。
我把有这个代码的工作簿放到需要合并的另一个文件夹，出现了错误。

冥王

1. Sub demo()
   
2.     UsedRange.Rows.Delete   '''''''''''''''''''''''''''''''''''''先清除工作表里面不需要的内容
   
3.     Dim p As String, f As String
   
4.     Dim s As Worksheet
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         .Title = "请选定要汇总的文件所在目录"
   
7.         .Show
   
8.         If .SelectedItems.Count = 0 Then Exit Sub
   
9.         p = .SelectedItems(1) & ""
   
10.     End With
    
11.     Application.ScreenUpdating = False
    
12.     f = Dir(p & "*.xls")
    
13.     Do While f <> ""
    
14.         Set w = Workbooks.Open(p & f)
    
15.         For Each s In w.Sheets
    
16.             s.UsedRange.Copy ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Offset(1, 0)
    
17.         Next
    
18.         w.Close False
    
19.         f = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

qh8600

为什么要合并，如一定要合并的话，何不把数据输入在一个表中

daniel32

谢谢各位

daniel32

冥王 发表于 2014-5-14 17:49

UsedRange.Rows.Delete   先清除工作表里面不需要的内容
这里出现错误，“运行时错误‘424’，要求对象”，什么原因？
屏蔽这句后可以运行，能得到想要结果。