导读：此程序用于提取与当前工作簿同在同一文件夹中，指定的单个工作表数据到当前工作簿中，作为单个工作表存在。取待汇入工作簿的名称作为汇入后的工作表名称 ，请据实修改变量wsk代表的工作表名称。
在汇总表中，使用了INDIRECT函数，确保各行对应的数据只取各行工作表中相应单元格的数据。 即，即使你在工行表中填入农行数据，汇总表中也不会汇入进来 。有关INDIRECT函数，感觉很好玩，你可以参阅帮助或关注后续推送文章。
操作演示：
代码：
Option Explicit
Sub WorksheetExtraction()
''变量声明
Dim twb As Workbook, wsk$, myFile$, shtName$, wbk As Workbook, sht As Worksheet
''将当前正在运行代码的工作簿指定给对象变量twb
Set twb = ThisWorkbook
''将待提取汇入的工作表指定给变量wsk，可据实修改
wsk = ''Sheet1''
''关掉屏幕更新，避免闪屏，加快运行速度
Application.ScreenUpdating = False
''返回正在运行代码的工作簿所在路径中的Excel文件
myFile = Dir(ThisWorkbook.Path & ''\*.xls*'')
''循环
Do While myFile > '' ''
''跳过当前代码正在运行的工作簿
If myFile <> twb.Name Then
''打开找到的Excel文件，指定给对象变量wbk
Set wbk = Workbooks.Open(twb.Path & ''\'' & myFile)
''取出打开的工作簿文件名（不带扩展名）指定给变量shtName
shtName = Left(wbk.Name, InStrRev(wbk.Name, ''.'') - 1)
''如果变量shtName的值（将以该变量作为工作表名称）在当前代码正在运行的工作簿中存在
If bWorksheetExist(shtName) Then
''清除全部单元格
twb.Sheets(shtName).Cells.Clear
''复制新打开的工作簿中wsk代表的工作表中的全部单元格到正在运行代码的工作簿中变量shtName对应的工作表A1
wbk.Sheets(wsk).Cells.Copy twb.Sheets(shtName).Cells(1, 1)
''若不存在
Else
''将打开的工作簿中wsk代表的工作表复制到当前正在运行代码的工作簿中所有工作表末尾
wbk.Sheets(wsk).Copy After:=twb.Sheets(Sheets.Count)
''将导入的工作表重命名为所打开的工作簿的名称
twb.ActiveSheet.Name = shtName
End If
''关闭打开的工作簿，不保存
wbk.Close False
End If
''查找下一个工作簿
myFile = Dir
''处理完一个Excel文件后绕回Do继续
Loop
Application.ScreenUpdating = True
MsgBox ''汇总完成！'', 64, ''提示''
End Sub
''自定义函数，判断传入的工作表名称是否在当前正在运行代码的工作簿中存在
Function bWorksheetExist(ByVal s As String) As Boolean
Dim twb As Workbook, sh As Worksheet
On Error Resume Next
Set twb = ThisWorkbook
Set sh = twb.Worksheets(s)
bWorksheetExist = Not sh Is Nothing
Set sh = Nothing: Set twb = Nothing
End Function
看图：
联系客服
