Извлечение определенных ячеек из нескольких файлов 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

Вам определенно не нужен весь этот код.

Попробуйте это - легче управлять, если вы разделите часть "find" на отдельный метод.

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