Excel VBA 逆引き集 | 複数一致を配列で返す

Excel VBA
スポンサーリンク

複数一致を配列で返す

「該当セルが複数あるから全部拾いたい」「行番号だけ欲しい」「値のリストを一括で返して貼りたい」。初心者でもそのまま使える、配列で返す安全テンプレと例題をまとめました。

使い分けの指針

  • 完全一致を高速に列挙: Find + FindNext（定型パターン）
  • 部分一致・柔軟条件: InStr（AND/ORも書きやすい）
  • パターン（電話・ID形式など）： 正規表現（RegExp）
  • 行番号だけ欲しい: 行番号配列テンプレ
  • 値をまとめて欲しい: 値配列テンプレ（貼り付け用）

基本テンプレ：Findで全件の「行番号配列」を返す

'完全一致/部分一致でヒットした「行番号」を配列で返す
Function FindAllRowNumbers(ByVal what As String, ByVal searchRange As Range, _
                           Optional ByVal partial As Boolean = False, _
                           Optional ByVal matchCase As Boolean = False) As Variant
    Dim lookAt As XlLookAt: lookAt = IIf(partial, xlPart, xlWhole)
    Dim hit As Range, first As String
    Dim rows As Collection: Set rows = New Collection

    Set hit = searchRange.Find(What:=what, LookAt:=lookAt, LookIn:=xlValues, MatchCase:=matchCase)
    If hit Is Nothing Then
        FindAllRowNumbers = Array()                 '空配列を返す
        Exit Function
    End If

    first = hit.Address
    Do
        rows.Add hit.Row
        Set hit = searchRange.FindNext(hit)
    Loop While Not hit Is Nothing And hit.Address <> first

    'Collection → 配列へ（高速：まとめて配列化）
    Dim i As Long, out() As Long
    ReDim out(0 To rows.Count - 1)
    For i = 1 To rows.Count
        out(i - 1) = CLng(rows(i))
    Next
    FindAllRowNumbers = out
End Function
VB
  • ポイント:
    • 無限ループ対策: 最初のアドレスに戻ったら終了。
    • ReDim Preserveを毎ループで使わない: まずCollectionに溜めて最後に配列化すると速い。
    • 戻り値は空配列: 未ヒットでも扱いやすい。

応用テンプレ：InStrで「部分一致の行番号配列」を返す

'部分一致（大小文字無視）でヒットした行番号を返す
Function RowsByContains(ByVal needle As String, ByVal searchRange As Range, _
                        Optional ByVal textCompare As VbCompareMethod = vbTextCompare) As Variant
    Dim lastRow As Long, startRow As Long, i As Long
    startRow = searchRange.Row
    lastRow = startRow + searchRange.Rows.Count - 1

    Dim rows As Collection: Set rows = New Collection
    Dim s As String
    For i = startRow To lastRow
        s = CStr(searchRange.Parent.Cells(i, searchRange.Column).Value)
        If InStr(1, s, needle, textCompare) > 0 Then rows.Add i
    Next

    Dim out() As Long
    If rows.Count = 0 Then
        RowsByContains = Array()
    Else
        ReDim out(0 To rows.Count - 1)
        For i = 1 To rows.Count: out(i - 1) = rows(i): Next
        RowsByContains = out
    End If
End Function
VB
  • ポイント:
    • 大小文字無視: vbTextCompare（デフォルト）で安定。
    • 自由度が高い: AND/ORや前後条件もループ内で足せる。

正規表現：パターン一致の行番号配列を返す

'パターンに一致する行番号を返す（例：ERRORの後に3桁）
Function RowsByRegex(ByVal pattern As String, ByVal searchRange As Range, _
                     Optional ByVal ignoreCase As Boolean = True) As Variant
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = pattern: re.IgnoreCase = ignoreCase: re.Global = False

    Dim rows As Collection: Set rows = New Collection
    Dim i As Long, startRow As Long, lastRow As Long, s As String
    startRow = searchRange.Row
    lastRow = startRow + searchRange.Rows.Count - 1

    For i = startRow To lastRow
        s = CStr(searchRange.Parent.Cells(i, searchRange.Column).Value)
        If re.Test(s) Then rows.Add i
    Next

    If rows.Count = 0 Then
        RowsByRegex = Array()
    Else
        Dim out() As Long: ReDim out(0 To rows.Count - 1)
        For i = 1 To rows.Count: out(i - 1) = rows(i): Next
        RowsByRegex = out
    End If
End Function
VB
  • ポイント:
    • 例: pattern = "\bERROR\d{3}\b" など。
    • キャプチャ値が欲しい場合: 行番号ではなく値配列に切り替え、re.Execute で SubMatches を取り出す。

値の配列を返すテンプレ（貼り付け用途）

'完全/部分一致で「値」を配列で返す（複数列対応）
Function FindAllValues(ByVal what As String, ByVal searchRange As Range, _
                       ByVal returnRange As Range, _
                       Optional ByVal partial As Boolean = False) As Variant
    Dim lookAt As XlLookAt: lookAt = IIf(partial, xlPart, xlWhole)
    Dim hit As Range, first As String
    Dim bag As Collection: Set bag = New Collection

    Set hit = searchRange.Find(What:=what, LookAt:=lookAt, LookIn:=xlValues)
    If hit Is Nothing Then
        FindAllValues = Array()
        Exit Function
    End If

    first = hit.Address
    Do
        '戻り範囲は複数列OK：同じ行のreturnRangeを行方向に抜く
        bag.Add returnRange.Parent.Range(returnRange.Rows(1).Address).Offset(hit.Row - returnRange.Row, 0) _
                .Resize(1, returnRange.Columns.Count).Value
        Set hit = searchRange.FindNext(hit)
    Loop While Not hit Is Nothing And hit.Address <> first

    'Collectionの各要素は1xNの配列 → まとめて2次元配列へ
    Dim r As Long, c As Long, out() As Variant
    If bag.Count = 0 Then
        FindAllValues = Array()
    Else
        ReDim out(1 To bag.Count, 1 To returnRange.Columns.Count)
        For r = 1 To bag.Count
            Dim rowArr As Variant: rowArr = bag(r)
            For c = 1 To returnRange.Columns.Count
                out(r, c) = rowArr(1, c)
            Next
        Next
        FindAllValues = out
    End If
End Function
VB
  • ポイント:
    • 複数列返却に対応: 例 → F:Gを返す。
    • そのまま貼り付け可能: Range("B2").Resize(UBound(out,1), UBound(out,2)).Value = out

配列の受け取りと貼り付け（ヘルパー）

'1) 行番号配列を受けとって一括色付け
Sub Demo_ColorRows()
    Dim rows As Variant
    rows = FindAllRowNumbers("商品A", Range("A2:A10000"), False)
    Dim i As Long
    For i = LBound(rows) To IBound(rows)
        Rows(rows(i)).Interior.Color = RGB(255, 235, 156)
    Next
End Sub

'2) 値配列を受けとって貼り付け
Sub Demo_PasteValues()
    Dim res As Variant
    res = FindAllValues("ERROR", Range("C2:C50000"), Range("F2:G50000"), True) 'Cで検索→F:Gを返す
    If IsEmpty(res) Then Exit Sub
    If IsArray(res) Then
        Worksheets("抽出").Range("A2").Resize(UBound(res, 1), UBound(res, 2)).Value = res
    End If
End Sub

'3) 行番号配列が空のときの安全判定
Function IBound(ByVal arr As Variant) As Long
    On Error Resume Next
    IBound = UBound(arr)
End Function
VB
  • ポイント:
    • 空配列判定: UBound がエラーになることがあるので、ヘルパーで安全に扱う。
    • 行番号配列の活用: 色付け・コピー・計算行指定など自由。

例題で練習

例題1：A列の「商品B」を全件見つけて、同じ行の数量×単価をH列へ

Sub Example_AllCalc()
    Dim rows As Variant, i As Long, r As Long
    rows = FindAllRowNumbers("商品B", Range("A2:A20000"))
    For i = LBound(rows) To IBound(rows)
        r = rows(i)
        Cells(r, "H").Value = Val(Cells(r, "C").Value) * Val(Cells(r, "D").Value)
    Next
End Sub
VB

例題2：部分一致「ERROR」を全件抽出して別シートへコピー

Sub Example_ExtractAllErrors()
    Dim rows As Variant, i As Long, outRow As Long
    rows = RowsByContains("ERROR", Range("A2:A80000"))
    outRow = 2
    For i = LBound(rows) To IBound(rows)
        Rows(rows(i)).Copy Destination:=Worksheets("抽出").Rows(outRow)
        outRow = outRow + 1
    Next
End Sub
VB

例題3：正規表現で「AAA-9999」を含む行を色付け

Sub Example_RegexCode()
    Dim rows As Variant, i As Long
    rows = RowsByRegex("\b[A-Z]{3}-\d{4}\b", Range("A2:A60000"))
    For i = LBound(rows) To IBound(rows)
        Rows(rows(i)).Interior.Color = RGB(200, 255, 200)
    Next
End Sub
VB

よくある落とし穴と対策

  • Find設定の引き継ぎで意図外検索になる
    • 対策: 毎回 LookAt/LookIn/MatchCase を明示。Find→FindNextは1ループで完結。
  • ReDim Preserve を毎ループで使ってしまい遅い
    • 対策: まずCollectionに入れて最後に一括で配列化。
  • 空配列の扱いでエラー
    • 対策: 空なら Array() を返す設計に。貼り側は UBound を安全に扱う。
  • 全角・半角・大小文字の揺れで取りこぼし
    • 対策: InStrなら vbTextCompare、Findなら MatchCase:=False。必要なら UCase/StrConv で正規化。
  • 戻り範囲の行ずれ
    • 対策: 値返却テンプレは「検索行と同じ行の戻り範囲」を確実に参照するよう Offset と Resize を使う。
スポンサーリンク
タイトルとURLをコピーしました