在Excel VBA上进行递归搜索

Question

我已经编写了一个excel VBA代码供用户输入id，并且excel数据表中的相应数据将显示为输出

Sub finddata()
    Dim North As Long
    Dim finalrow As Long
    Dim i As Long
    Dim count As Long
    Sheets("ML").Range("K5:P200").ClearContents
    North = Sheets("ML").Range("K2").Value
    finalrow = WorksheetFunction.CountA(Sheet1.Columns(1))
    For i = 2 To finalrow
        If Cells(i, 4) = North Then
            Range(Cells(i, 1), Cells(i, 6)).Copy
            Range("K100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        End If
    Next i
End Sub

现在，我需要修改代码以递归搜索结果。例如-通过上述搜索得到的输出单元格ID也会以不同的Con号出现在父单元格ID字段中。我们还需要征募那些人。此循环应继续进行直到显示完整的集合。任何帮助将不胜感激

Answer 1

正如一条评论所述，您应该使用.findnext;话虽如此，我会尝试的：

Sub finddata()

Dim North As Long
Dim finalrow As Long
Dim i As Long
Dim count As Long

Sheets("ML").Range("K5:P200").ClearContents
North = Sheets("ML").Range("K2").Value
finalrow = WorksheetFunction.CountA(Sheet1.Columns(1))

With ActiveSheet.Range("A1:F" & finalrow)

    Set cellid = .Cells.Find(What:=North)

    If Not cellid Is Nothing Then

        Do Until cellid Is Nothing

            Range(Cells(cellid.Row, 1), Cells(cellid.Row, 6)).Copy
            Range("K100000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats

            Set cellid = .FindNext(cellid)
        Loop

    End If

End With

End Sub

Answer 2

或者只是使用高级过滤器：

sub findRecords()

    Range("K3:P200").ClearContents

    Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "K1:K2"), CopyToRange:=Range("K5"), Unique:=False

End Sub

您甚至可以将其放在onChange事件中的工作表代码模块中，并在每次在 K2 单元格中设置条件时自动运行它，如下所示：

1. 右键单击工作表标签，然后单击View Code

2. 粘贴以下代码：

   Private Sub Worksheet_Change(ByVal Target As Range)
   If Len(Target) >= 5 Then
       Application.EnableEvents = False
   Else
       Exit Sub
   End If
   
   Range("K3:P200").ClearContents
   
   Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
           "K1:K2"), CopyToRange:=Range("K5"), Unique:=False
   
   Application.EnableEvents = True
   
   End Sub