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

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

1 个答案: