求一个VBA，一个文件夹中多个EXCEL工作簿合并成一个工作表？

Question

一个文件夹中多个名称不同的EXCEL工作簿，每个工作簿里面有1-3个工作表，工作表的名字也不相同，求一个VBA能够把所有工作蒲里的每个表的内容都复制到一个新的工作表里面（不是一个工作簿里面），网上找了很多代码都不能合并，不知道怎么回事。

Answer 1

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这个文件中。

Answer 2

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放在同一个工作簿即可实现。

本回答被网友采纳

Answer 3

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

本回答被提问者采纳

Answer 4

Sub t1()
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

Answer 5

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放在同一个工作簿即可实现

追问

没反映啊

追答

你打开文件33的文件，打开编辑器，运行a的代码，如果还是不会就看附件，替换原来的文件，直接点击按钮就行，不过你要将这个excel和你需要的excel放在同一个路径

本回答被网友采纳