VBA一键复制当前文件夹全部EXCEL里的工作表

1、【准备条件1】新建专用文件夹。

2、【准备条件2】在文件夹内放若干EXCEL文件备用，格式、内容、数量不限。

3、【开始制作】在该文件夹下新建EXCEL工作簿，并将工作表1改名为导入清单，A1输入工作簿名称、B1输入工作表名称。

4、【打基础1】从左上角文件里面找到EXCEL选项设置，打开选择自定义功能区，将里面的开发工具选项打勾，确定保存。

5、【打基础2】删除sheet2、sheet3，只留导入清单，文件保存为 启用宏的工作簿（*.xlsm）

6、【关键步骤】从开发工具里打开Visual Basic, 新建模块1，将以下代码复制到里面，保存，关闭代码窗口。

Public Sub 一键获取本文件夹工作表()

Application.ScreenUpdating = False

Dim f As String, i As Integer

Dim wb As Excel.Workbook

Dim sh, sh1 As Excel.Worksheet

Set sh1 = ThisWorkbook.Worksheets("导入清单")

If Range("a65536").End(xlUp).Row > 1 Then

sh1.Range("a2:b" & Range("a65536").End(xlUp).Row).Clear

End If

f = Dir(ThisWorkbook.Path & "\*xls*")

Do While f <> ""

If f <> ThisWorkbook.Name Then

Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)

For i = 1 To Sheets.Count

sh1.Range("a" & sh1.Range("a65536").End(xlUp).Row + 1) = wb.Name

sh1.Range("b" & sh1.Range("b65536").End(xlUp).Row + 1) = Sheets(i).Name

Next

    Worksheets.Copy Before:=Workbooks(ThisWorkbook.Name).Sheets(1)

    wb.Close True

    End If

    f = Dir

Loop

sh1.Select

Application.ScreenUpdating = True

MsgBox "已为您成功导入" & Sheets.Count - 1 & "张工作表", , "VBA交流QQ15678768"

End Sub

7、【再来一步】从开发工具，插入，表单控件，选择按钮。

8、【接近尾声】在任意空白位置拖动鼠标画一个按钮，跳出指定宏对话框，

选择“一键获取本文件夹工作表“，确定保存。

9、【大功告成】点击按钮，查看效果。