从某个文件夹中的文件复制工作表

我正在试图从我的计算机中的某个文件夹中的文件复制工作表。 我想有一个主要的工作簿（Workbook1），我按下一个button，从每个xls或xlsm文件从某个文件夹（C：\位置）的第一张表。 我现在拥有的是以下。

Sub read_a_folder() Dim MainWB As String strPath = "C:\Location\" MainWB = ActiveWorkbook.Name Set objFso = CreateObject("Scripting.FileSystemObject") Set objFolder = objFso.GetFolder(strPath) For Each objFile In objFolder.Files If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then End If Next End Sub 

所以即时通讯错过了复制工作表，因为它是我的主要工作簿。 我已经尝试使用ActiveSheet.QueryTables.Add但复制工作表的特殊格式使其不可读。 当我手动执行时，Ctrl + Shift + End和CTRL + C将起作用。

任何帮助是非常需要的。

谢谢。

Answer 1

只是为了跟上戴夫的代码（ – >信贷给他！）一些增强（和一个小的修订）

 Option Explicit Sub read_a_folder() Dim objFso As FileSystemObject Dim objFolder As Folder Dim objFile As File Dim MainWB As Workbook Dim strPath As String strPath = "C:\Location\" Set MainWB = ActiveWorkbook '<~~ Workbook is an object -> you must "Set" it Set objFso = CreateObject("Scripting.FileSystemObject") Set objFolder = objFso.GetFolder(strPath) Application.ScreenUpdating = False '<~~ this will reduce the flickering and speed it all up For Each objFile In objFolder.Files If objFso.GetExtensionName(objFile.Path) Like "xls*" Then '<~~ use "Like" operator to check for all "xls..." extensions in a single check With Workbooks.Open(objFile.Path, False, True) '<~~ no need to set an object, just instantiate it and work with it! Furthermore let's use some of the "Open" method parameters to avoid prompts popping out .Worksheets(1).Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet .Close False End With End If Next Application.ScreenUpdating = True '<~~ turn screen updating on End Sub 

Answer 2

以下可能会有所帮助：

 Sub read_a_folder() Dim MainWB As Workbook Dim objSheet As Worksheet strPath = "C:\Location\" MainWB = ActiveWorkbook.Name Set objFso = CreateObject("Scripting.FileSystemObject") Set objFolder = objFso.GetFolder(strPath) For Each objFile In objFolder.Files If objFso.GetExtensionName(objFile.Path) = "xls" Or objFso.GetExtensionName(objFile.Path) = "xlsm" Then Set objWb = Workbooks.Open objFile.Path Set objSheet = objWb.Worksheets(1) ' sets first sheet objSheet.Copy After:=MainWB.Sheets(MainWB.Sheets.Count) 'copies after last worksheet objWb.Close Set objSheet = Nothing Set objWb = Nothing End If Next End Sub