从多个 Excel 文件中提取特定单元格并将其编译为一个 Excel 文件

Question

我是 VBA 新手，我想用它来完成一些困难而艰巨的任务。我有大量包含数千行和数列的 Excel 文件。我需要按行搜索并提取具有特定字符串的某些单元格。我已经拼凑了一些函数和代码，几乎可以让它工作，但我不断得到意外的结果，比如提取不相关的数据或随机错误，因为我不太了解 VBA 语法。作为 Excel 的新手，我正在竭尽全力调试这段代码，但它仍然没有给我需要的结果。到目前为止，我的代码如下：

Option Explicit

Sub ImportDataFromMultipleFiles()
Dim firstAddress As Variant
Dim filenames As Variant
Dim i As Long
Dim rFind As Range
Dim firstFile As String
Dim n As Long
Dim r As Range
Dim myArray() As Integer

ThisWorkbook.Activate
Application.ScreenUpdating = False
Range("a2").Select
filenames = Application.GetOpenFilename _
(FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)
Application.FindFormat.Clear

For i = 1 To UBound(filenames) 'counter for files
firstFile = filenames(i)
Workbooks.Open firstFile 'Opens individual files in folder
n = 0

With ActiveSheet.UsedRange
      Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=True, SearchFormat:=False)
        If Not rFind Is Nothing Then
            firstAddress = rFind.Address
            Do
            n = n + 1
            Set rFind = .FindNext(rFind)
            Selection.Copy
            ThisWorkbook.Activate
            Selection.PasteSpecial
            ActiveCell.Offset(0, 1).Activate
            Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
        End If
    End With

ReDim myArray(0, n)
n = 0
Workbooks.Open firstFile 'Opens individual files in folder

With ActiveSheet.UsedRange
    Set rFind = .Find("Test*Results:", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
            If Not rFind Is Nothing Then
            firstAddress = rFind.Address
            Do
            myArray(0, n) = rFind.Row '<<< Error currently here
            n = n + 1
            Set rFind = .FindNext(rFind)
            Selection.Copy
            ThisWorkbook.Activate
            Selection.PasteSpecial
            ActiveCell.Offset(0, 1).Activate
            Loop While Not rFind Is Nothing And rFind.Address <> firstAddress
        End If
    End With

For n = LBound(myArray) To UBound(myArray)
Debug.Print "Rows are: " & myArray(0, n)
Next n

Workbooks.Open filenames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate

Next i

End Sub

我什至不确定第二个循环是否必要，但使用它已经为我提供了迄今为止我正在寻找的最接近的结果。这段代码将涵盖大量数据，因此任何使我的代码更高效的建议都将不胜感激。 提前致谢！

Answer 1

您绝对不需要所有这些代码。

试试这个 - 如果您将“查找”部分拆分为单独的方法，则更易于管理。

Option Explicit

Sub ImportDataFromMultipleFiles()

    Dim filenames As Variant, wb As Workbook
    Dim rngDest As Range, colFound As Collection, f, i As Long

    Set rngDest = ActiveSheet.Range("A2") '<< results start here

    filenames = Application.GetOpenFilename( _
        FileFilter:="Excel Filter(*xlsx), *.xlsx", MultiSelect:=True)

    If TypeName(filenames) = "Boolean" Then Exit Sub '<< nothing selected

    Application.FindFormat.Clear

    For i = 1 To UBound(filenames) 'counter for files

        Set wb = Workbooks.Open(filenames(i))
        Set colFound = FindAll(wb.Sheets(1).UsedRange, "Test*Results:") '<< get matches
        Debug.Print "Found " & colFound.Count & " matches in " & wb.Name '<<EDIT
        For Each f In colFound
            f.Copy rngDest
            Set rngDest = rngDest.Offset(1, 0)
            Debug.Print "", f.Value
        Next f

        wb.Close False
    Next i

End Sub

Public Function FindAll(rng As Range, val As String) As Collection
    Dim rv As New Collection, f As Range
    Dim addr As String

    Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.Count), _
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=True)
    If Not f Is Nothing Then addr = f.Address()

    Do Until f Is Nothing
        rv.Add f
        Set f = rng.FindNext(after:=f)
        If f.Address() = addr Then Exit Do
    Loop

    Set FindAll = rv
End Function