Excel VBA 逆引き集 | 複数条件検索

Excel VBA
スポンサーリンク

複数条件検索

「A列がX かつ B列がY」「部分一致＋日付範囲」「ORを混ぜる」など、現場でよくある複数条件検索を、初心者でも迷わず使えるテンプレでまとめます。最短はAutoFilter、柔軟ならInStr＋If、爆速は配列＋辞書、列保持CSVならQueryTablesが安定です。

選び方の指針

  • 見た目の抽出が目的: AutoFilter（最短・安定）
  • 柔軟条件（部分一致・AND/OR・数値/日付混在）: ループ＋If（InStr/Like/範囲判定）
  • 大量データ・繰り返し: 配列＋辞書（キー正規化で高速）
  • 式で一気に判定→値化: COUNTIFS/IF/AND/OR をFormulaで投入
  • CSVなど列構造を保ちたい: QueryTablesで取り込み後にAutoFilter

最短テンプレ：AutoFilterで複数条件

AND（かつ）・OR（または）の基本

Sub Filter_AND_OR()
    With Range("A1").CurrentRegion
        'AND: A列=営業 AND B列=完了
        .AutoFilter Field:=1, Criteria1:="営業"
        .AutoFilter Field:=2, Criteria1:="完了"

        'OR: C列=ERROR/WARN
        .AutoFilter Field:=3, Criteria1:=Array("ERROR", "WARN"), Operator:=xlFilterValues

        '抽出後コピー
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter '解除
    End With
End Sub
VB
  • ポイント:
    • AND: 別フィールドにそれぞれ条件指定。
    • OR: 同一フィールドに配列条件。
    • 部分一致: Criteria1:=”文字” を使う。

日付範囲（開始〜終了）

Sub Filter_DateRange()
    Dim startD As Date, endD As Date
    startD = DateSerial(2025, 1, 1)
    endD = DateSerial(2025, 1, 31)
    With Range("A1").CurrentRegion
        .AutoFilter Field:=4, Operator:=xlAnd, _
            Criteria1:=">=" & CLng(startD), Criteria2:="<=" & CLng(endD)
    End With
End Sub
VB
  • ポイント:
    • 日付はシリアルで比較。 CLng(Date) で渡すと安定。

柔軟検索：ループ＋If（部分一致・数値/日付判定）

Sub Search_MultiConditions()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Long, sA As String, sC As String, d As Date, n As Double
    Dim startD As Date: startD = DateSerial(2025, 1, 1)
    Dim endD As Date:   endD = DateSerial(2025, 1, 31)

    Dim out As Worksheet: Set out = Worksheets("抽出")
    Dim outRow As Long: outRow = 2

    For r = 2 To last
        sA = CStr(Cells(r, "A").Value)       '例：部署（部分一致）
        sC = CStr(Cells(r, "C").Value)       '例：レベル（完全一致）
        d = Cells(r, "B").Value              '例：日付
        n = Val(Cells(r, "D").Value)         '例：金額

        If InStr(1, sA, "営業", vbTextCompare) > 0 _
           And sC = "ERROR" _
           And d >= startD And d <= endD _
           And n >= 10000 Then
            Rows(r).Copy Destination:=out.Rows(outRow)
            outRow = outRow + 1
        End If
    Next
End Sub
VB
  • ポイント:
    • AND/ORは自由に構築。
    • 部分一致: InStr（vbTextCompareで大小文字無視）。
    • 数値/日付: Valと比較、DateSerialで範囲化。

式で一気に判定→値化（COUNTIFS/AND/OR）

Sub Mark_WithFormula()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    'E列に判定式（TRUE/FALSE）を入れて値化
    With Range("E2:E" & last)
        .Formula = "=AND(COUNTIF(A2,""*営業*""),B2>=DATE(2025,1,1),B2<=DATE(2025,1,31),C2=""ERROR"",D2>=10000)"
        .Value = .Value
    End With
    'TRUE行だけ抽出
    With Range("A1").CurrentRegion
        .AutoFilter Field:=5, Criteria1:=True
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub
VB
  • ポイント:
    • 計算式で超高速一括判定。 値化して再計算負荷をゼロに。

大量データ向け：配列＋辞書で高速抽出

単一条件を先に絞る（OR条件は集合化）

Sub Fast_ArrayDict_Multi()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim rg As Range: Set rg = Range("A1").CurrentRegion
    Dim v As Variant: v = rg.Value '配列へ
    Dim rowsHit As Object: Set rowsHit = CreateObject("Scripting.Dictionary") '行インデックス集合

    Dim i As Long, dept As String, level As String, d As Date, amt As Double
    For i = 2 To UBound(v, 1)
        dept = CStr(v(i, 1))
        level = CStr(v(i, 3))
        d = v(i, 2)
        amt = Val(v(i, 4))
        If InStr(1, dept, "営業", vbTextCompare) > 0 _
           And (level = "ERROR" Or level = "WARN") _
           And d >= DateSerial(2025, 1, 1) And d <= DateSerial(2025, 1, 31) _
           And amt >= 10000 Then
            rowsHit(i) = True
        End If
    Next

    '抽出書き出し（配列で一括）
    Dim out() As Variant, cnt As Long: cnt = rowsHit.Count
    If cnt > 0 Then
        ReDim out(1 To cnt, 1 To UBound(v, 2))
        Dim k As Variant, rOut As Long: rOut = 1
        For Each k In rowsHit.Keys
            Dim c As Long
            For c = 1 To UBound(v, 2)
                out(rOut, c) = v(k, c)
            Next
            rOut = rOut + 1
        Next
        Worksheets("抽出").Range("A1").Resize(1, UBound(v, 2)).Value = rg.Rows(1).Value 'ヘッダー
        Worksheets("抽出").Range("A2").Resize(cnt, UBound(v, 2)).Value = out
    End If

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • セル往復を避ける: 範囲→配列→条件→一括書き出し。
    • OR条件: その場で判定（またはヒット行を辞書へ収集）。

CSVを列保持で取り込み→複数条件検索

Sub ImportCsv_AndFilter()
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "\data.csv", Destination:=Range("A1"))
        .TextFileCommaDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .Refresh BackgroundQuery:=False
    End With

    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="営業"
        .AutoFilter Field:=3, Criteria1:=Array("ERROR", "WARN"), Operator:=xlFilterValues
        .AutoFilter Field:=4, Operator:=xlAnd, Criteria1:=">=10000", Criteria2:="<=99999999"
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub
VB
  • ポイント:
    • 列構造があるログ/データはQueryTables→AutoFilterが最短。

安全・高速ラップ（大量時の基本）

Sub SafeWrapStart()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Sub SafeWrapEnd()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 前後停止→復帰で体感が変わる。エラー時も復帰できるよう On Error GoTo Cleanup を併用。

よくある落とし穴と対策

  • ラベル: 条件の大小・全角半角・大小文字の揺れで漏れる
    • 対策: 文字列は UCase/CStr で統一、必要なら StrConv(..., vbNarrow/vbWide)。
  • ラベル: 部分一致が過剰ヒット
    • 対策: InStr前後を精査（区切り記号や語尾を含める）、完全一致は = に切り替え。
  • ラベル: 日付が文字列で比較されてしまう
    • 対策: Date型へ変換（セルに正しく日付が入っているか確認）。AutoFilterはシリアル比較が安全。
  • ラベル: セル往復が多くて遅い
    • 対策: 配列で一括処理して書き戻す。抽出はまとめて貼る。
  • ラベル: AutoFilterの解除忘れ
    • 対策: 抽出後は .AutoFilter で必ず解除。次回処理が狂うのを防ぐ。

例題で練習

'例1：A列「*営業*」 AND C列=ERROR/WARN AND B列=2025/1月 AND D列>=10000 を抽出
Sub Example_FilterMulti()
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="*営業*"
        .AutoFilter Field:=3, Criteria1:=Array("ERROR", "WARN"), Operator:=xlFilterValues
        .AutoFilter Field:=2, Operator:=xlAnd, Criteria1:=">=1/1/2025", Criteria2:="<=1/31/2025"
        .AutoFilter Field:=4, Criteria1:=">=10000"
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub

'例2：柔軟条件（OR混在）で抽出シートへ書き出し
Sub Example_LoopIfMulti()
    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim outRow As Long: outRow = 2
    Dim r As Long, sA As String, sC As String
    For r = 2 To last
        sA = CStr(Cells(r, "A").Value): sC = CStr(Cells(r, "C").Value)
        If (InStr(1, sA, "営業", vbTextCompare) > 0 Or InStr(1, sA, "販売", vbTextCompare) > 0) _
           And (sC = "ERROR" Or sC = "WARN") Then
            Rows(r).Copy Destination:=Worksheets("抽出").Rows(outRow)
            outRow = outRow + 1
        End If
    Next
End Sub

'例3：配列＋辞書で高速抽出（営業/ERROR/WARN/金額>=10000）
Sub Example_ArrayDictMulti()
    Call Fast_ArrayDict_Multi '本文の高速テンプレをそのまま利用
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました