Question

* UPDATE

提供的答案有所帮助，但我在文件夹中找到excel文件时遇到了一些问题。我使用了一个对话框允许用户选择文件夹来协助这个，这似乎有效，但我现在收到运行时错误438（对象不支持此属性或方法）。从文件夹打开第一个Excel工作簿后发生这种情况（FileToOpen = Workbooks.Open（Fold））

我在下面提供了更新的代码。有关如何修改的想法吗？

之前的帖子： 我在更新代码时遇到了一些问题，使我能够为多个Excel工作表选择/执行操作。代码本身旨在打开一本excel书，将适当的数据复制到“数据库”中并将其关闭。我希望它能够遍历特定文件夹中的每个工作簿，每次都执行相同的操作，直到所有工作簿都提取了数据。感谢一些帮助！

代码如下：

Sub ImportData()
'This sub is designed to pull the data from the respective spreadsheets into the Database
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sheet As Worksheet
Dim FolderPath As FileDialog
Dim Fold As String
Dim Directory As String


Set wb1 = ActiveWorkbook
Application.ScreenUpdating = True
'select the path to the folder you want

Set FolderPath = Application.FileDialog(msoFileDialogFolderPicker)

    With FolderPath
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        Directory = .SelectedItems(1) & "\"
    End With

NextCode:
  Fold = ""

Fold = Dir(Directory)

Do While Fold <> ""
Application.ScreenUpdating = False
FileToOpen = Workbooks.Open(Fold)

    Set wb2 = Workbooks.Open(Filename:=FileToOpen)
        For Each sheet In wb1.Sheets
            With sheet.UsedRange
                Loopy = Range("B1").End(xlDown).Offset(1, 0)
            End With
        Next sheet

        L = wb1.Sheets("Database").Cells(Rows.Count, "B").End(xlUp).Row + 1

        'Name
        wb2.Sheets("Feedback").Range("D4").Copy
        wb1.Sheets("Database").Range("B" & L).PasteSpecial xlPasteValues
        'Paper
        wb2.Sheets("Feedback").Range("D5").Copy
        wb1.Sheets("Database").Range("C" & L).PasteSpecial xlPasteValues
        'Date
        wb2.Sheets("Feedback").Range("D6").Copy
        wb1.Sheets("Database").Range("D" & L).PasteSpecial xlPasteValues
        'Completed by
        wb2.Sheets("Feedback").Range("D7").Copy
        wb1.Sheets("Database").Range("E" & L).PasteSpecial xlPasteValues
        'rating
        wb2.Sheets("Feedback").Range("J20").Copy
        wb1.Sheets("Database").Range("F" & L).PasteSpecial xlPasteValues
        'qualifiers
        wb2.Sheets("Feedback").Range("C17").Copy
        wb1.Sheets("Database").Range("G" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("D17").Copy
        wb1.Sheets("Database").Range("H" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("E17").Copy
        wb1.Sheets("Database").Range("I" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("F17").Copy
        wb1.Sheets("Database").Range("J" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("G17").Copy
        wb1.Sheets("Database").Range("K" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("H17").Copy
        wb1.Sheets("Database").Range("L" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("I17").Copy
        wb1.Sheets("Database").Range("M" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("J17").Copy
        wb1.Sheets("Database").Range("N" & L).PasteSpecial xlPasteValues

        'comments
        wb2.Sheets("Feedback").Range("B18").Copy
        wb1.Sheets("Database").Range("O" & L).PasteSpecial xlPasteValues

    wb2.Close
Fold = Dir()
Loop

End Sub

Answer 1

这将循环遍历您在“Dir（）”中放置的任何路径中的每个文件，并按照您之前的代码进行处理。您可能需要添加决策以决定要处理哪些文件，因为这将遍历文件夹中的每个文件。

Sub ImportData()
'This sub is designed to pull the data from the respective spreadsheets into the Database
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sheet As Worksheet
Dim FolderPath As String
Dim Fold as Variant



Set wb1 = ActiveWorkbook
'opens a file select box
Fold = Dir("C:/User/Folder Name/") ' Change the path to the folder you want

Do While Fold <> ""

FileToOpen = Workbooks.Open(Fold)

If FileToOpen = False Then
    MsgBox "No File Specified.", vbExclamation, "ERROR"
    Exit Sub
Else
    Set wb2 = Workbooks.Open(Filename:=FileToOpen)
        For Each sheet In wb1.Sheets
            With sheet.UsedRange
                Loopy = Range("B1").End(xlDown).Offset(1, 0)
            End With
        Next sheet

   L = wb1.Sheets("Database").Cells(Rows.Count, "B").End(xlUp).Row + 1

        'Sheet names & cell copy and pastes
        wb2.Sheets("Feedback").Range("D4").Copy
        wb1.Sheets("Database").Range("B" & L).PasteSpecial xlPasteValues
        'Paper
        wb2.Sheets("Feedback").Range("D5").Copy
        wb1.Sheets("Database").Range("C" & L).PasteSpecial xlPasteValues
        'Date
        wb2.Sheets("Feedback").Range("D6").Copy
        wb1.Sheets("Database").Range("D" & L).PasteSpecial xlPasteValues
        'Completed by
        wb2.Sheets("Feedback").Range("D7").Copy
        wb1.Sheets("Database").Range("E" & L).PasteSpecial xlPasteValues
        'rating
        wb2.Sheets("Feedback").Range("J20").Copy
        wb1.Sheets("Database").Range("F" & L).PasteSpecial xlPasteValues
        'qualifiers
        wb2.Sheets("Feedback").Range("C17").Copy
        wb1.Sheets("Database").Range("G" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("D17").Copy
        wb1.Sheets("Database").Range("H" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("E17").Copy
        wb1.Sheets("Database").Range("I" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("F17").Copy
        wb1.Sheets("Database").Range("J" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("G17").Copy
        wb1.Sheets("Database").Range("K" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("H17").Copy
        wb1.Sheets("Database").Range("L" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("I17").Copy
        wb1.Sheets("Database").Range("M" & L).PasteSpecial xlPasteValues

        wb2.Sheets("Feedback").Range("J17").Copy
        wb1.Sheets("Database").Range("N" & L).PasteSpecial xlPasteValues

        'comments
        wb2.Sheets("Feedback").Range("B18").Copy
        wb1.Sheets("Database").Range("O" & L).PasteSpecial xlPasteValues

End If

    wb2.Close
Fold = Dir()
Loop
End Sub

VBA - 从多个Excel工作表中提取数据

1 个答案: