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

Question

我正在尝试从我计算机中某个文件夹中的文件中复制作品sheet。我想要一个主工作簿 (Workbook1)，我在其中按下一个按钮，该按钮从特定文件夹 (C:\Location) 的每个 xls 或 xlsm 文件中获取第一个 sheet。我目前拥有的如下。

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

所以我错过了将 sheet 复制到我的主工作簿的方法。我试过使用 ActiveSheet.QueryTables.Add 但复制的 sheet 的特殊格式使其不可读。当我手动执行时，Ctrl+Shift+End 和 CTRL+C 有效。

非常需要任何帮助。

谢谢。

Answer 1

以下内容可能有所帮助：

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

Answer 2

只是为了跟进 Dave 的代码（-> 归功于他！）并进行了一些增强（和一点点修改）

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

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

Copying a worksheet from a file in a certain folder

excel

vba

copy-paste

worksheet