【Excel VBA】FindNextで複数の検索結果をすべて取得する方法｜無限ループを防ぐ書き方

Sub FindNextAll()

    Dim ws As Worksheet
    Dim targetRange As Range
    Dim foundCell As Range
    Dim firstAddress As String
    Dim outputRow As Long

    ' 検索範囲と出力先を設定する
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set targetRange = ws.Range("A2:A9")
    ws.Range("C1:D10").ClearContents
    ws.Range("C1").Value = "行番号"
    ws.Range("D1").Value = "商品コード"
    outputRow = 2

    ' Findで最初の一致セルを取得する
    Set foundCell = targetRange.Find( _
        What:="A001", _
        After:=targetRange.Cells(targetRange.Count), _
        LookIn:=xlValues, _
        LookAt:=xlWhole, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=False, _
        MatchByte:=False, _
        SearchFormat:=False)

    '見つからない場合は処理を終了する
    If foundCell Is Nothing Then
        MsgBox "該当するデータがありません。"
        Exit Sub
    End If

    ' 最初のセル番地を保存して全件検索する
    firstAddress = foundCell.Address

    Do
        '一致したセルの行番号と値を出力する
        ws.Cells(outputRow, "C").Value = foundCell.Row
        ws.Cells(outputRow, "D").Value = foundCell.Value
        outputRow = outputRow + 1

        '同じ条件で次の一致セルを取得する
        Set foundCell = targetRange.FindNext(After:=foundCell)

        '次のセルが取得できない場合は終了する
        If foundCell Is Nothing Then Exit Do

        '最初のセルに戻ったら終了する
    Loop While foundCell.Address <> firstAddress

    MsgBox outputRow - 2 & "件見つかりました。", vbInformation

End Sub