vba - 查找下一个仅适用于第一次迭代

Question

我接下来的发现有一个问题，很可能是我错误地编写了代码。因此，如果我有号码 810(即 f)，找到该地址，再次 810 找到 810 其他位置的地址，依此类推...

然后我的前两个工作正常。因此，当第一次 findnext 时，它会按我想要的方式工作，粘贴到最后一个单元格，但其他单元格不起作用。所以当我第二次查找next时，它不再复制粘贴了。知道如何修复它吗？

With RgnScenarioScenario

    Set f = .Find(What:=f, LookIn:=xlValues, LookAt:=xlWhole)
    WsScenarios.Activate
    f.Select
    q = f.Address
    Set x = Range("A:A").FindNext(f)
    x.Select
    z = x.Address
    Set m = Range("A:A").FindNext(f)
    m.Select
    n = m.Address
    Set k = Range("A:A").FindNext(f)
    k.Select
    w = k.Address
    Set a = Range("A:A").FindNext(f)
    a.Select
    g = a.Address

    If q <> z Then

    Range(z).Offset(0, 5).Select
    Range(ActiveCell, ActiveCell.Offset(0, ScenarioLastColumn - 6)).Copy

    WsOutput.Activate
    WsOutput.Cells(lLastRow, Columnf).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

    Else

    End If

    If z <> n Then

    Range(n).Offset(0, 5).Select
    Range(ActiveCell, ActiveCell.Offset(0, ScenarioLastColumn - 6)).Copy

    WsOutput.Activate
    WsOutput.Cells(lLastRow, Columnf).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Else

    End If

    If n <> w Then

    Range(n).Offset(0, 5).Select
    Range(ActiveCell, ActiveCell.Offset(0, ScenarioLastColumn - 5)).Copy

    WsOutput.Activate
    WsOutput.Cells(lLastRow, Columnf).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Else

    End If

    If w <> g Then

    Range(n).Offset(0, 5).Select
    Range(ActiveCell, ActiveCell.Offset(0, ScenarioLastColumn - 5)).Copy

    WsOutput.Activate
    WsOutput.Cells(lLastRow, Columnf).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Else

    End If

    End With
    Next f

我的代码正在寻找的是场景 ID 的范围值，在本例中为 810。正如您在第一个打印屏幕中看到的那样，我有 3 次 810。在下面只需识别 2。这就是问题，它应该尽可能多地识别它。我在这 block 上很挣扎。我尝试了自动过滤，但没有解决我的问题。这一切都与操作 ID 有关。有 3，所以，我的代码应该带上 3

Answer 1

附件是一个“FindAll”函数，您可以使用它吗？

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: Set SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function