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

I'm new to VBA, and I'd like to use it to do some difficult and arduous tasks. I have a large amount of Excel files with thousands of rows and several columns. I need to search, by row, and extract certain cells with specific strings. I've pieced together some functions and code and I have almost got it to work but I keep getting unexpected results like irrelevant data being extracted or it random errors because I don't understand VBA syntax super well. As a newbie to Excel, I'm at my wits end debugging this code and it still not giving me the results I need. My code thus far is as follows:

我是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

I'm not even sure if the second loop is necessary, but using it has given me the closest results for what I'm looking for thus far. This code is going to cover a lot of data, so any suggestions to make my code more efficient as well will be much appreciated. Thanks in advance!

我甚至不确定第二个循环是否必要,但是使用它给了我迄今为止最接近的结果。这段代码将涵盖大量数据,因此我们非常感谢任何使我的代码更高效的建议。提前致谢!

1 个解决方案

#1

You definitely don't need all that code.

你绝对不需要所有的代码。

Try this out - it's easier to manage if you split out the "find" part into a separate method.

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

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

#1