求一个VBA,一个文件夹中多个EXCEL工作簿合并成一个工作表?
发布网友
发布时间：2022-04-30 21:11
共8个回答
热心网友
时间：2022-04-18 22:43
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这个文件中。
热心网友
时间：2022-04-19 00:01
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放在同一个工作簿即可实现。
热心网友
时间：2022-04-19 01:36
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
热心网友
时间：2022-04-19 03:27
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
热心网友
时间：2022-04-19 05:35
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放在同一个路径
热心网友
时间：2022-04-19 08:00
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet
Application.ScreenUpdating = False
Set sh = ActiveSheet
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
[a1].CurrentRegion.Offset(2).Clear
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If sht.[a1].CurrentRegion.Rows.Count > 2 Then
lr = sh.[a1].CurrentRegion.Rows.Count + 1
r = sht.[a1].CurrentRegion.Rows.Count - 2
sh.Cells(lr, 1).Resize(r) = MyName
sh.Cells(lr, 2).Resize(r) = sht.Name
sht.[a1].CurrentRegion.Offset(2).Copy sh.Cells(lr, 3)
End If
Next
.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
试试这个
追问没有反映的就显个OK追答操作如下：
1、在同文件夹下建立一个新表格
2、复制代码
3、执行
如果没有反应，那么检查一下：
1、所有分表的数据是否存在，如果只是一个表头，是不会合并的。
2、所有表格的格式是.xls还是.xlsx？如果是后者，那么代码中的*.xls改成*.xls*
检查过后还是没有反应，把你的分表截图上来看看
热心网友
时间：2022-04-19 10:41
路径只能是在：f/新建文件夹，我是win7系统显示的路径如下图有点和以前的XP不一样，
格式是一个的但内容多少不一样，表名和工作簿名不一样，复制全部包含表头，如果一个表里中间有空行那也要把后面的全部内容包括空行都合并过去
打开文件,Alt+F8运行,在工具文件相同路径下生成Totaldata_yyyymmdd文件.
代码中的myPath路径修改为实际路径即可.
Sub Files2Sheet()Application.ScreenUpdating = False
Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
myPath = "C:\test\"
myFile = Dir(myPath & "*.xls*")
Cells.Clear
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then
Set AK = Workbooks.Open(myPath & myFile)
For i = 1 To AK.Sheets.Count
aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row
tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
AK.Sheets(i).Range("a1:t" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow)
Next
Workbooks(myFile).Close False
End If
myFile = Dir
Loop
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\Totaldata_" & Format(Date, "yyyymmdd"), FileFormat:=xlNormal
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
