VBA-从多张excel工作表中提取数据

*更新

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

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

以前的帖子： 我在更新代码以使我能够选择/执行多张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

子导入数据（）
'此子模块旨在将数据从相应的电子表格中拉入数据库
将wb1设置为工作簿
将wb2设置为工作簿
将工作表设置为工作表
Dim FolderPath As FileDialog
朦胧如线
将目录设置为字符串
设置wb1=ActiveWorkbook
Application.ScreenUpdating=True
'选择所需文件夹的路径
Set FolderPath=Application.FileDialog（msoFileDialogFolderPicker）
使用FolderPath
.Title=“选择目标文件夹”
.AllowMultiSelect=False
如果.Show-1，则转到下一个代码
目录=.SelectedItems（1）和“\”
以
下一个代码：
Fold=“”
Fold=Dir（目录）
“边折叠边做”
Application.ScreenUpdating=False
FileToOpen=工作簿。打开（折叠）
设置wb2=工作簿.打开（文件名：=FileToOpen）
对于wb1.Sheets中的每张工作表
使用sheet.UsedRange
Loopy=范围（“B1”）。结束（xlDown）。偏移量（1，0）
以
下一页
L=wb1.Sheets（“数据库”）.单元格（Rows.Count，“B”）.结束（xlUp）.行+1
“名字
wb2.工作表（“反馈”）.范围（“D4”）.副本
wb1.工作表（“数据库”）.范围（“B”和“L”）.粘贴特殊XLPaste值
"纸",
wb2.工作表（“反馈”）.范围（“D5”）.副本
wb1.工作表（“数据库”）.范围（“C”和“L”）.粘贴特殊XLPaste值
“日期
wb2.工作表（“反馈”）.范围（“D6”）.副本
wb1.工作表（“数据库”）.范围（“D”和L）.粘贴特殊XLPaste值
"填妥者:
wb2.工作表（“反馈”）.范围（“D7”）.副本
wb1.工作表（“数据库”）.范围（“E”和“L”）.粘贴特殊XLPaste值
“评级
wb2.工作表（“反馈”）.范围（“J20”）.副本
wb1.工作表（“数据库”）.范围（“F”和L）.粘贴特殊XLPaste值
“资格赛
wb2.工作表（“反馈”）.范围（“C17”）.副本
wb1.工作表（“数据库”）.范围（“G”和L）.粘贴特殊XLPaste值
wb2.表格（“反馈”）.范围（“D17”）.副本
wb1.表格（“数据库”）.范围（“H”和“L”）.粘贴特殊XLPaste值
wb2.工作表（“反馈”）.范围（“E17”）.副本
wb1.工作表（“数据库”）.范围（“I”和“L”）.粘贴特殊XLPaste值
wb2.工作表（“反馈”）.范围（“F17”）.副本
wb1.工作表（“数据库”）.范围（“J”和“L”）.粘贴特殊XLPaste值
wb2.表格（“反馈”）.范围（“G17”）.副本
wb1.工作表（“数据库”）.范围（“K”和L）.粘贴特殊XLPaste值
wb2.表格（“反馈”）.范围（“H17”）.副本
wb1.工作表（“数据库”）.范围（“L”和“L”）.粘贴特殊XLPaste值
wb2.工作表（“反馈”）.范围（“I17”）.副本
wb1.图纸（“数据库”）.范围（“M”和L）.粘贴特殊XLPaste值
wb2.表格（“反馈”）.范围（“J17”）.副本
wb1.表格（“数据库”）.范围（“N”和“L”）.粘贴特殊XLPaste值
评论
wb2.工作表（“反馈”）.范围（“B18”）.副本
wb1.工作表（“数据库”）.范围（“O”和“L”）.粘贴特殊XLPaste值
wb2.关闭
Fold=Dir（）
环
端接头

这将在您放入“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

子导入数据（）
'此子模块旨在将数据从相应的电子表格中拉入数据库
将wb1设置为工作簿
将wb2设置为工作簿
将工作表设置为工作表
将FolderPath设置为字符串
作为变体的模糊折叠
设置wb1=ActiveWorkbook
'打开一个文件选择框
Fold=Dir（“C:/User/Folder Name/”）更改所需文件夹的路径
“边折叠边做”
FileToOpen=工作簿。打开（折叠）
如果FileToOpen=False，则
MsgBox“未指定文件”，VBEQUOTE，“错误”
出口接头
其他的
设置wb2=工作簿.打开（文件名：=FileToOpen）
对于wb1.Sheets中的每张工作表
使用sheet.UsedRange
Loopy=范围（“B1”）。结束（xlDown）。偏移量（1，0）
以
下一页
L=wb1.Sheets（“数据库”）.单元格（Rows.Count，“B”）.结束（xlUp）.行+1
'工作表名称&单元格复制和粘贴
wb2.工作表（“反馈”）.范围（“D4”）.副本
wb1.工作表（“数据库”）.范围（“B”和“L”）.粘贴特殊XLPaste值
"纸",
wb2.工作表（“反馈”）.范围（“D5”）.副本
wb1.工作表（“数据库”）.范围（“C”和“L”）.粘贴特殊XLPaste值
“日期
wb2.工作表（“反馈”）.范围（“D6”）.副本
wb1.工作表（“数据库”）.范围（“D”和L）.粘贴特殊XLPaste值
"填妥者:
wb2.工作表（“反馈”）.范围（“D7”）.副本
wb1.工作表（“数据库”）.范围（“E”和“L”）.粘贴特殊XLPaste值
“评级
wb2.工作表（“反馈”）.范围（“J20”）.副本
wb1.工作表（“数据库”）.范围（“F”和L）.粘贴特殊XLPaste值
“资格赛
wb2.工作表（“反馈”）.范围（“C17”）.副本
wb1.工作表（“数据库”）.范围（“G”和L）.粘贴特殊XLPaste值
wb2.表格（“反馈”）.范围（“D17”）.副本
wb1.表格（“数据库”）.范围（“H”和“L”）.粘贴特殊XLPaste值
wb2.她