vba - 在 Excel VBA 中的搜索中搜索值

Question

我对这个 VBA 世界完全陌生，我只是在摸索表面，需要我能得到的任何帮助。

这是我的问题
我正在尝试编写一个找到值(第一个值)的代码
如果找到值，则开始新的搜索以查找子值，而不会到达(第一个值)上第二次命中的地址[完全难以解释，所以这里是示例]

如果我有一个像下面这样的名字列表

    John C
    age       32
    address   bla bla bla
    DOB       1/2/1990

    Marc D
    DOB       1/2/1989      
    age       32            
    address   bla bla bla 2 


    John D
    address   bla bla bla3
    age       48
    DOB   1/2/1970

    David K 
    age       32
    address   bla bla bla 4
    DOB       1/2/1985

我需要实现以下目标

首先搜索所有名为 John

的民族

在不同的工作表中键入名称

然后获取找到的每个 John 的年龄

在姓名

旁边的单元格中输入该年龄

我尝试了一个代码，但我认为它有点不准确

Sub Copy_To_Another_Sheet_1()

Dim FirstAddress As String
Dim MyArr As Variant
Dim MyArr2 As Variant
Dim Rng As Range
Dim Rng2 As Range
Dim Rcount As Long
Dim I As Long
Dim J As Long
Dim NewSh As Worksheet

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

MyArr = Array("John")
MyArr2 = Array("Age")
Set NewSh = Sheets("Sheet3")

With Sheets("Sheet1").Range("A1:Z1000")
    Rcount = 5

    For I = LBound(MyArr) To UBound(MyArr)

        Set Rng = .Find(What:=MyArr(I), _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then

            FirstAddress = Rng.Address

            Do
                Rcount = Rcount + 1
                Rng.Copy NewSh.Range("G" & Rcount)
                Set Rng = .FindNext(Rng)
               For J = LBound(MyArr2) To UBound(MyArr2)
                Set Rng2 = .Find(What:=MyArr2(J), _
                            After:=Rng, _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                If Not Rng2 Is Nothing Then
                    Rng2.Offset(, 1).Copy NewSh.Range("H" & Rcount)
                End If

                Next J
                Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress

        End If

    Next I

End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

我在这里使用 Array 来设置我的搜索参数，因为在该代码的最终版本中，我需要能够找到名称列表及其相关信息。

找到前几个值后，我不断收到错误。

很感谢任何形式的帮助

提前致谢

Answer 1

您可能想尝试对代码进行这种重构

Option Explicit

Sub Copy_To_Another_Sheet_1()
    Dim namesArr As Variant, name As Variant
    Dim dataArr As Variant, datum As Variant
    Dim rCount As Long
    Dim reportSht As Worksheet

    Dim namesRng As Range
    Dim arr As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    namesArr = Array("John", "Mark")
    dataArr = Array("Age", "Address", "DOB")
    Set reportSht = Sheets("Sheet3")
    rCount = 5 '<--| initialize row index to start writing data from
    With Sheets("Sheet1") '<--| reference "Sheet1"
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--| reference its column "A" cells from row 1 down to last non empty one
            For Each name In namesArr '<--| loop through "names" array
                Set namesRng = GetNames(.Cells, name) '<--| collect current name occurrences in referenced cells
                If Not namesRng Is Nothing Then '<--| if any occurrence has been found then...
                    For Each datum In dataArr '<--| ...loop through "data" array
                        arr = GetData(name, namesRng, datum) '<--| collect current "data" occurrences under current name ones
                        If IsArray(arr) Then '<-- if any data has been found then...
                            reportSht.Range("G" & rCount).Resize(, UBound(arr) + 1).Value = arr '<-- ... write data in 'reportShtt'
                            rCount = rCount + 1 '<--| update row index to write data in
                        End If
                    Next datum
                End If
            Next name
        End With
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub


Function GetNames(rng As Range, name As Variant) As Range
    Dim f As Range, unionRng As Range
    Dim firstAddress As String

    Set unionRng = rng.Resize(1, 1).Offset(, 1)
    With rng
        Set f = .Find(What:=name, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
        If Not f Is Nothing Then
            firstAddress = f.Address
            Do
                Set unionRng = Union(unionRng, f)
                Set f = .FindNext(f)
            Loop While Not f Is Nothing And f.Address <> firstAddress
        End If
        Set GetNames = Intersect(unionRng, .Cells)
    End With
End Function


Function GetData(name As Variant, rng As Range, datum As Variant) As Variant
    Dim cell As Range
    Dim data As String

    For Each cell In rng
        Do While cell <> ""
            If UCase(cell) = UCase(datum) Then
                data = data & cell.Offset(, 1) & "|"
                Exit Do
            End If
            Set cell = cell.Offset(1)
        Loop
    Next cell
    If data <> "" Then GetData = Split(name & "|" & Left(data, Len(data) - 1), "|")
End Function