Question

我正在尝试从计算机中某个文件夹中的文件复制工作表。我想有一个主工作簿（Workbook1），我按下一个按钮，从某个文件夹（C：\ Location）的每个xls或xlsm文件中获取第一张工作表。我目前的情况如下。

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

只是为了跟进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

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

从特定文件夹中的文件复制工作表

2 个答案: