excel - 设置 Excel VBA 以使用 40 个单独的 Excel 工作表打开 40 个单独的文件夹

Question

Excel VBA：设置 VBA 代码以使用 40 个单独的 Excel 工作表打开 40 个单独的文件夹，并将工作表中的特定相同单元格复制并粘贴到一个大表中。

Answer 1

此方法适用于 excel 2003：

Sub CopyFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    On Error Resume Next

    Set wbCodeBook = ThisWorkbook

    Dim cntr As Integer
    cntr = 1

    With Application.FileSearch
        .NewSearch
         'Change path to suit
        .LookIn = "C:\MyDocuments\TestResults"
        .FileType = msoFileTypeExcelWorkbooks
         '.Filename = "Book*.xls"

        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count 'Loop through all.
                 'Open Workbook x and Set a Workbook variable to it
                Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

                    'Copy R4C9 from each workbook into range
                    wbCodeBook.Worksheets(1).Range("A" & cntr).Value = wbResults.Worksheets(1).Cells(4, 9).Value
                    cntr = cntr + 1

                wbResults.Close SaveChanges:=False

            Next lCount
        End If
    End With

    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

---

Excel 2007 及更高版本尝试以下方法。这将打开一个文件对话框，允许您选择一个文件夹，其中包含您想要循环的所有 excel 文件。请注意，文件扩展名是 .xls，但可以根据需要进行更改。

Sub CopyFiles()
    Dim lCount As Long
    Dim wbResults As Workbook
    Dim wbCodeBook As Workbook

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    On Error Resume Next

    Set wbCodeBook = ThisWorkbook

    Dim cntr As Integer
    cntr = 1

    Dim sPath As String
    Dim sFil As String
    Dim FolderPath As String
    Dim diaFolder As FileDialog

    Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
      diaFolder.AllowMultiSelect = False
      diaFolder.Show
      FolderPath = diaFolder.SelectedItems(1)

      sPath = FolderPath & "\" 'location of files
      sFil = Dir(sPath & "*.xls") 'change or add formats

    Do While sFil <> ""
        Set wbResults = Workbooks.Open(sPath & "\" & sFil) 'opens the file
            wbCodeBook.Worksheets(1).Range("A" & cntr).Value = wbResults.Worksheets(1).Cells(4, 9).Value
            cntr = cntr + 1

        wbResults.Close True
        sFil = Dir
    Loop

    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub