VBAで全て検索と同等の関数作った

作るきっかけ

• FindからのFindNextの処理を毎回検索して書き直すのがめんどくさい
• メインの処理にDo Loopが入って見にくい

使用上の注意点

• Raiseするエラー番号がテキトー
• RangeのCollectionだから検索対象のブックを閉じると参照できなくなる

全て検索する関数

とりあえず書いたけど、もっとスマートにできそう。

Public Function FindAll(ByRef What As String, ByRef Scope As Variant) As Collection
    ' 検索と置換の[全て検索(I)]に近い関数
    '
    ' Args:
    '       What (String): 検索対象文字列。 Cells.[Find|FindNext]に渡すWhat。
    '       Scope (Workbook|Worksheet): 検索範囲を示す。渡されたオブジェクトの全体を検索
    '
    ' Returns:
    '       Result: (Collection): 検索にヒットしたRangeのCollection
    '
    
    ' Scopeの型判定
    Dim TargetSheets As Object
    Select Case TypeName(Scope)
        Case "Workbook"
            Set TargetSheets = Scope.Worksheets
        Case "Worksheet"
            Set TargetSheets = New Collection
            TargetSheets.Add Scope
        Case Else
            Err.Raise 999, Scope, "Scopeの型はWorkbookかWorksheetにして下さい。"
    End Select
    ' Return用Collection
    Dim Result As Collection: Set Result = New Collection
    ' 検索結果の一時格納変数
    Dim FoundCell1 As Range, FoundCell2 As Range
    ' ループ用Worksheet
    Dim Ws As Worksheet
    For Each Ws In TargetSheets
        ' 最初の検索
        Set FoundCell1 = Ws.Cells.Find(What:=What, LookIn:=xlValues, LookAt:=xlPart)
        ' 検索結果が無ければ次のシートに
        If FoundCell1 Is Nothing Then GoTo NextWs
        ' 検索結果をCollectionに格納
        Result.Add FoundCell1
        ' シート内を複数検索するためのループ
        Do
            ' 次のセルを検索
            Set FoundCell2 = Ws.Cells.FindNext(After:=Result(Result.Count))
            ' ヒットしたセル番地と最初に検索したセルの番地が同じだったら次のシートに
            If FoundCell1.Address(external:=True) = FoundCell2.Address(external:=True) Then Exit Do
            ' 検索結果をCollectionに格納
            Result.Add FoundCell2
        Loop
NextWs: ' 他言語のContinue代わり
    Next
    Set FindAll = Result
End Function

使い方

Scopeに検索対象のオブジェクトを渡す。

Sub Test()
    Dim FoundCells As Collection, FoundCell As Range
    
    ' シート内全検索
    Set FoundCells = FindAll("A", Sheet1)
    For Each FoundCell In FoundCells
        Debug.Print FoundCell.Address(external:=True); vbTab; FoundCell.Value
    Next
    
    ' ブック内全検索
    Set FoundCells = FindAll("A", ThisWorkbook)
    For Each FoundCell In FoundCells
        Debug.Print FoundCell.Address(external:=True); vbTab; FoundCell.Value
    Next
End Sub

イミディエイトウィンドウの出力

[FindAll.xlsm]Sheet1!$B$2    A
[FindAll.xlsm]Sheet1!$C$5    ASC
[FindAll.xlsm]Sheet1!$B$6    AB
[FindAll.xlsm]Sheet1!$B$7    aaA
[FindAll.xlsm]Sheet1!$B$2    A
[FindAll.xlsm]Sheet1!$C$5    ASC
[FindAll.xlsm]Sheet1!$B$6    AB
[FindAll.xlsm]Sheet1!$B$7    aaA
[FindAll.xlsm]Sheet2!$B$2    AC
[FindAll.xlsm]Sheet2!$C$4    AD
[FindAll.xlsm]Sheet2!$B$6    AV