求一个VBA，一个文件夹中多个EXCEL工作簿合并成一个工作表？
一个文件夹中多个名称不同的EXCEL工作簿，每个工作簿里面有1-3个工作表，工作表的名字也不相同，求一个VBA能够把所有工作蒲里的每个表的内容都复制到一个新的工作表里面（不是一个工作簿里面），网上找了很多代码都不能合并，不知道怎么回事。
1、将需要合并的EXCEL文件与目的EXCEL文件放在一个文件夹下。
2、 打开HB.xlsx，将“开发工具”菜单加载到EXCEL菜单下。
3、首先右键点击菜单空白处，选择“自定义功能区”，在弹出的对话框里选择主选项卡。然后勾选“开发工具”。如图所示。
4、 制作导入键。点击“开发工具”菜单，选择“插入”--“Activex”控件下的命令按键。在工作表中画一个命令按钮。
5、 单击“开发工具”下的“设计模式”，再双击刚刚创建的命令按钮“CommandButton1”,进入代码编辑框。
6、 将以下代码全部复制到代码框中。
7、 将HB文件保存成启用宏的工作簿。关闭当前代码框，回到EXCEL界面。选择“文件”--“另存为”--“保存类型”下选择“启用宏的工作簿”，OK。
8、打开HB.xlsm,单击按钮。则几个需要合并的EXCEL文件中的工作表A,B,C合并到了HB.xlsm这个文件中。
VBA代码如下：
Sub s()
pth = "D:\My Documents\" '在这里输入文件所在文件夹的完整路径
fn = Dir(pth & "*.xls")
Set newbk = Workbooks.Add
Set sht = newbk.Sheets(1)
k = 1
Application.DisplayAlerts = False
Do While fn <> ""
Set wb = Workbooks.Open(pth & fn)
For i = 1 To wb.Sheets.Count
sht.Cells(k, 1) = fn & ":" & wb.Sheets(i).Name
k = k + 1
wb.Sheets(i).UsedRange.Copy
sht.Cells(k, 1).PasteSpecial xlPasteValuesAndNumberFormats
k = sht.UsedRange.Rows.Count + 1
Next
wb.Close False
fn = Dir
Loop
newbk.SaveAs pth & "new.xlsx" '在这里设定合并文件的文件名
newbk.Close False
Application.DisplayAlerts = True
End Sub
扩展资料：
也可以用如下代码实现：
Sub a()
For Each myfile In CreateObject("scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
If myfile.Name Like "*.xl*" And Not myfile.Name Like "*" & ThisWorkbook.Name & "*" Then
With Workbooks.Open(myfile)
sheetcount = .Sheets.Count
For i = 1 To sheetcount
.Sheets(i).Copy After:=ThisWorkbook.Sheets(1)
Next
.Close False
End With
End If
Next
ThisWorkbook.Save
End Sub
将所有的excel放在同一个工作簿即可实现。
本回答被网友采纳pth = "D:\My Documents\" '在这里输入文件所在文件夹的完整路径
fn = Dir(pth & "*.xls")
Set newbk = Workbooks.Add
Set sht = newbk.Sheets(1)
k = 1
Application.DisplayAlerts = False
Do While fn <> ""
Set wb = Workbooks.Open(pth & fn)
For i = 1 To wb.Sheets.Count
sht.Cells(k, 1) = fn & ":" & wb.Sheets(i).Name
k = k + 1
wb.Sheets(i).UsedRange.Copy
sht.Cells(k, 1).PasteSpecial xlPasteValuesAndNumberFormats
k = sht.UsedRange.Rows.Count + 1
Next
wb.Close False
fn = Dir
Loop
newbk.SaveAs pth & "new.xlsx" '在这里设定合并文件的文件名
newbk.Close False
Application.DisplayAlerts = True
End Sub本回答被提问者采纳
Dim fdOpen As FileDialog
Dim fdPath$, fo, fd, f, xls, sh, dsh, r%
Set fdOpen = Application.FileDialog(msoFileDialogFolderPicker)
With fdOpen
If .Show Then fdPath = .SelectedItems(1)
End With
Set fo = CreateObject("Scripting.FileSystemObject")
Set fd = fo.GetFolder(fdPath)
Set dsh = ThisWorkbook.Sheets.Add
dsh.Name = "合并" & ThisWorkbook.Sheets.Count
r = 1
dsh.Activate
Application.ScreenUpdating = False
For Each f In fd.Files
If f.Name <> ThisWorkbook.Name And Not f.Name Like "~$*" And (f.Name Like "*.xls" Or f.Name Like "*.xlsx") Then
Set xls = Workbooks.Open(f.Name)
For Each sh In xls.Sheets
sh.UsedRange.Copy dsh.Cells(r, 1)
r = r + sh.UsedRange.Rows.Count
Next
xls.Close
End If
Next
Application.ScreenUpdating = True
End Sub
===========================
Sub t2()Dim fdOpen As FileDialog
Dim fdPath$, f, xls, sh, dsh, r%
Set fdOpen = Application.FileDialog(msoFileDialogFolderPicker)
With fdOpen
If .Show Then fdPath = .SelectedItems(1)
End With
Set dsh = ThisWorkbook.Sheets.Add
dsh.Name = "合并" & ThisWorkbook.Sheets.Count
r = 1
dsh.Activate
Application.ScreenUpdating = False
f = Dir(fdPath & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name And Not f Like "~$*" Then
Set xls = Workbooks.Open(f)
For Each sh In xls.Sheets
sh.UsedRange.Copy dsh.Cells(r, 1)
r = r + sh.UsedRange.Rows.Count
Next
xls.Close
End If
f = Dir()
Loop
Application.ScreenUpdating = True
End Sub
For Each myfile In CreateObject("scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
If myfile.Name Like "*.xl*" And Not myfile.Name Like "*" & ThisWorkbook.Name & "*" Then
With Workbooks.Open(myfile)
sheetcount = .Sheets.Count
For i = 1 To sheetcount
.Sheets(i).Copy After:=ThisWorkbook.Sheets(1)
Next
.Close False
End With
End If
Next
ThisWorkbook.Save
End Sub
将所有的excel放在同一个工作簿即可实现
没反映啊
追答你打开文件33的文件，打开编辑器，运行a的代码，如果还是不会就看附件，替换原来的文件，直接点击按钮就行，不过你要将这个excel和你需要的excel放在同一个路径