Excel VBA（マクロ）で部分一致検索条件にヒットするデータを全て列挙する方法

マクロを実行すると、データ内の該当する項目が全部縦に並べられる、というマクロです。コピペ可です。

成果物
解説（ざっくり）
関連項目も表示させる（VlokUp）

成果物

Sheet2にはこのようにデータが並んでおり、

Sheet1では検索窓にデータを打ち込めます。

マクロを実行すると、部分一致する検索対象が全て表示されます。

' vba
Sub 部分一致検索()

    '検索結果を書き込むセル
    Dim sht1 As Range
    Dim sht1cnt As Integer
    sht1cnt = 2
    Set sht1 = Sheets("Sheet1").Cells(sht1cnt, 1)

    '検索内容
    Dim wht As String
    
    '検索内容の取得
    wht = Sheets("Sheet1").Cells(1, 1).Value
    
    'Sheet1の前の検索結果をクリア
    Sheets("Sheet1").Range("A2:A1000").ClearContents

    '検索用
    Dim foundCell As Range
    Dim firstCell As Range
    
    Set foundCell = Sheets("Sheet2").Range("A:A").Find(What:=wht, lookat:=xlPart)
    
    If foundCell Is Nothing Then ' 見つからない場合①
    MsgBox "検索条件に合うものが見付かりません"
    
    Else
    
        sht1.Value = foundCell.Value
        sht1cnt = sht1cnt + 1
        Set sht1 = Sheets("Sheet1").Cells(sht1cnt, 1)

        '最初の検索結果をfirstCellとして保存
        Set firstCell = foundCell
        
        '同じ条件で続けて検索（ループ）
        Do
            Set foundCell = Sheets("Sheet2").Range("A:A").FindNext(After:=foundCell)
            
            If foundCell Is Nothing Then ' 見つからない場合②
                Exit Do ' ループ終了
            End If ' 見つからない場合②の終わり
            
            '最初の検索結果と現在の検索結果が同じ場合アドレスを表示しない
            If foundCell.Address <> firstCell.Address Then
                sht1.Value = foundCell.Value
                sht1cnt = sht1cnt + 1
                Set sht1 = Sheets("Sheet1").Cells(sht1cnt, 1)
            End If
            
        '最初の検索結果＝現在の検索結果の場合ループ終了
        Loop Until foundCell.Address = firstCell.Address
    End If ' 見つからない場合①の終わり

End Sub

解説（ざっくり）

ExcelVBA（マクロ）でセルを検索・置換する方法/Find、Replaceメソッドの使い方

マクロを使っていくと、特定の値を検索してそれに干渉したり、条件に該当するセルだけ置換したりといった操作が要求される場面が出てきます。そうした場合は、FindメソッドやReplaceメソッドを使うことで対応できるかもしれません。

ほとんどFindメソッドの記事で解説したことしかしていない（コードも流用している）ので、そっち見てもらうほうが話が早いんですが、

' vba
Set foundCell = Sheets("Sheet2").Range("A:A").Find(What:=wht, lookat:=xlPart)

通常の検索に加えて、LookAtをxlPartに設定することで部分一致検索にしています。
その他プロパティでいくつか細かい調整が可能です。

' vba
Set foundCell = Sheets("Sheet2").Range("A:A").FindNext(After:=foundCell)

FindNextは前のFindの設定を引き継いで再度検索することができるメソッドです。
一周すると自動で止まる、みたいな機能は残念ながらないので、そこは条件で判定させています。

成果物

解説（ざっくり）

関連項目も表示させる（VlokUp）

コメント