【マクロ・VBA】縦（行）ループして文字列を部分一致させる

VBA

2023.03.18

ループ／部分一致　Like演算子

Sub Like部分一致()
    Dim i As Long
    For i = 2 To 12
        Cells(i, 3) = Cells(i, 1) Like Cells(i, 2)
    Next
    MsgBox "完了"
End Sub

ループして部分一致したものを抽出

指定された列で指定された複数の文字列や数字が含まれる行を抽出し、新しいシートに出力するVBAコードの例です。この例では、抽出する列がB列で、文字列として”A”と”X”を含む行、数字として2と5を含む行を抽出しています。

Sub 抽出()

    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rngSource As Range
    Dim rngDest As Range
    Dim arrCriteria As Variant
    Dim i As Long

    '元データシート
    Set wsSource = ThisWorkbook.Sheets("Sheet1")

    '出力先シート
    Set wsDest = ThisWorkbook.Sheets.Add
    wsDest.Name = "抽出結果"

    '抽出する列
    Set rngSource = wsSource.Range("B:B")

    '抽出条件
    arrCriteria = Array("A", "X", 2, 5)

    '出力範囲の開始行を指定
    Set rngDest = wsDest.Range("A2")

    '条件に一致する行をコピー
    For i = LBound(arrCriteria) To UBound(arrCriteria)
        rngSource.AutoFilter Field:=1, Criteria1:="*" & arrCriteria(i) & "*"
        rngSource.SpecialCells(xlCellTypeVisible).Copy rngDest
        Set rngDest = rngDest.Offset(rngSource.SpecialCells(xlCellTypeVisible).Cells.Count)
        rngSource.AutoFilter Field:=1
    Next i

    '出力先シートの見出し行
    wsDest.Range("A1:B1").Value = Array("行番号", "抽出データ")

    '出力範囲の行番号を追加
    wsDest.Range("A2:A" & wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Row).Formula = "=ROW()-1"

    '完了メッセージ
    MsgBox "抽出が完了しました。"

End Sub

このコードは、条件に一致する行を一つずつ抽出していくため、条件数が多い場合は処理が遅くなる可能性があります。また、大量のデータを扱う場合はメモリの使用量にも注意してください。