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

Question

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

3

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

我甚至不确定第二个循环是否必要，但使用它已经为我带来了迄今为止最接近我想要的结果。这段代码将涵盖大量数据，因此任何使我的代码更有效的建议都将不胜感激。

提前致谢！

- Jessica Christensen

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- Tim Williams · Accepted Answer

你肯定不需要那么多的代码。

试试这个方法 - 如果你将“查找”部分拆分成一个单独的方法，它会更容易管理。

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