Excel VBA 逆引き集 | 前方一致の高速検索

Excel VBA
スポンサーリンク

前方一致の高速検索

「先頭が〇〇で始まる」を爆速で見つけたいときの定番は、Findの部分一致、Likeのワイルドカード、Dictionary＋配列の前処理です。件数や用途ごとに最短テンプレを用意しました。

選び方の指針

  • 小〜中規模を素早く1回検索: Range.Find（LookAt:=xlPart、FindNextで全件）
  • 大量データを何度も検索: 配列＋Dictionary（前方一致用インデックス）
  • パターンが明確（「ABC*」など）: Like（ワイルドカード）
  • 表の絞り込みだけで良い: AutoFilter（Criteria1:=”ABC*”)

基本：Range.Find（前方一致）で全件列挙

Sub PrefixFind_All_FindNext()
    Dim src As Range, hit As Range, first As String, prefix As String
    Set src = Range("A2:A80000")
    prefix = "ABC"

    '部分一致指定（前方一致は値を絞るのがコツ）
    Set hit = src.Find(What:=prefix, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
    If hit Is Nothing Then Exit Sub

    first = hit.Address
    Do
        If Left$(CStr(hit.Value), Len(prefix)) = prefix Then
            Debug.Print "ヒット: "; hit.Address; " 値="; hit.Value
        End If
        Set hit = src.FindNext(hit)
    Loop While Not hit Is Nothing And hit.Address <> first
End Sub
VB
  • ポイント:
    • FindのxlPartは「含む」。誤ヒット抑制のため、Leftで前方一致を追加チェック。
    • 無限ループ防止は「最初のアドレスに戻ったら終了」。

最短：Like（ワイルドカード）で前方一致

Sub PrefixFind_All_Like()
    Dim last As Long, r As Long, prefix As String
    prefix = "ABC"
    last = Cells(Rows.Count, "A").End(xlUp).Row

    For r = 2 To last
        If CStr(Cells(r, "A").Value) Like prefix & "*" Then
            Cells(r, "A").Interior.Color = RGB(255, 235, 156)
        End If
    Next
End Sub
VB
  • ポイント:
    • Likeは「prefix*」で前方一致。大小文字はExcelの既定に依存（厳密制御はUCase比較で）。

爆速：配列＋Dictionaryで前方一致（大量・繰り返しに強い）

1. 先頭文字でインデックス化（粗く分割して高速化）

Sub PrefixIndex_CharBucket()
    Dim rng As Range: Set rng = Range("A2:A200000")
    Dim v As Variant: v = rng.Value            '配列へ一括
    Dim buckets As Object: Set buckets = CreateObject("Scripting.Dictionary") 'key=先頭1文字, value=行番号配列

    Dim i As Long, s As String, k As String
    For i = 1 To UBound(v, 1)
        s = CStr(v(i, 1))
        If Len(s) > 0 Then
            k = Left$(s, 1)
            If Not buckets.Exists(k) Then buckets.Add k, Array()
            Call AppendIndexArray(buckets, k, i) '下のヘルパーで配列に追加
        End If
    Next

    '検索（例：prefix="ABC"）
    Dim prefix As String: prefix = "ABC"
    k = Left$(prefix, 1)
    If buckets.Exists(k) Then
        Dim idxs As Variant: idxs = buckets(k)
        For i = LBound(idxs) To UBound(idxs)
            s = CStr(v(idxs(i), 1))
            If Left$(s, Len(prefix)) = prefix Then
                'ヒット処理（例：色付け）
                rng.Cells(idxs(i), 1).Interior.Color = RGB(255, 235, 156)
            End If
        Next
    End If
End Sub

Private Sub AppendIndexArray(ByRef dict As Object, ByVal key As String, ByVal index As Long)
    Dim arr As Variant: arr = dict(key)
    Dim n As Long: On Error Resume Next: n = UBound(arr) + 1: On Error GoTo 0
    ReDim Preserve arr(n)
    arr(n) = index
    dict(key) = arr
End Sub
VB
  • ポイント:
    • 先頭1文字（必要なら2〜3文字）ごとのバケット化で候補を激減。
    • 同じprefixで何度も検索する場面（入力補助など）で劇的に速い。

2. 完全な前方インデックス（prefix長Lで作る）

Sub PrefixIndex_Full()
    Dim L As Long: L = 3                    'インデックスに使う先頭文字数
    Dim rng As Range: Set rng = Range("A2:A200000")
    Dim v As Variant: v = rng.Value
    Dim index As Object: Set index = CreateObject("Scripting.Dictionary") 'key=先頭L文字, value=行番号配列

    Dim i As Long, s As String, key As String
    For i = 1 To UBound(v, 1)
        s = CStr(v(i, 1))
        If Len(s) >= L Then
            key = Left$(s, L)
            If Not index.Exists(key) Then index.Add key, Array()
            AppendIndexArray index, key, i
        End If
    Next

    '検索（prefixの長さに応じてキーを決める）
    Dim prefix As String: prefix = "ABC"
    key = Left$(prefix, L)
    If index.Exists(key) Then
        Dim idxs As Variant: idxs = index(key)
        For i = LBound(idxs) To UBound(idxs)
            s = CStr(v(idxs(i), 1))
            If Left$(s, Len(prefix)) = prefix Then
                rng.Cells(idxs(i), 1).Font.Bold = True
            End If
        Next
    End If
End Sub
VB
  • ポイント:
    • L文字キーで候補を極小に。prefix長に応じてキーを合わせる。
    • 先頭ゼロ・大小文字揺れは事前に正規化（例：UCase、文字列化）。

絞り込みだけなら：AutoFilterで前方一致

Sub PrefixFilter()
    With Range("A1").CurrentRegion
        .AutoFilter Field:=1, Criteria1:="ABC*"
        '可視行を抽出など
        .SpecialCells(xlCellTypeVisible).Copy Worksheets("抽出").Range("A1")
        .AutoFilter
    End With
End Sub
VB
  • ポイント:
    • 「表示上の抽出」なら最少コードで実用的。

入力補助（オートコンプリート風）

Sub Prefix_Autocomplete()
    Dim prefix As String: prefix = InputBox("先頭文字を入力（例：ABC）")
    If Len(prefix) = 0 Then Exit Sub

    Dim rng As Range: Set rng = Range("A2:A50000")
    Dim v As Variant: v = rng.Value
    Dim list As Object: Set list = CreateObject("System.Collections.ArrayList")

    Dim i As Long, s As String
    For i = 1 To UBound(v, 1)
        s = CStr(v(i, 1))
        If Left$(UCase$(s), Len(prefix)) = UCase$(prefix) Then
            list.Add s
            If list.Count >= 50 Then Exit For '候補上限
        End If
    Next

    If list.Count = 0 Then
        MsgBox "候補なし": Exit Sub
    End If
    list.Sort
    Worksheets("候補").Range("A2").Resize(list.Count, 1).Value = WorksheetFunction.Transpose(list.ToArray)
End Sub
VB
  • ポイント:
    • 大小文字無視の前方一致で候補を上限付き表示。
    • 高速用途は前述のインデックス化に置き換え可。

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

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

Sub SpeedWrap_End()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB
  • ポイント:
    • 前後で停止→復帰するだけで体感が大きく改善。
    • エラー時でも復帰するようにOn ErrorでCleanupへ。

よくある落とし穴と対策

  • 前方一致なのに「含む」まで拾ってしまう
    • 対策: FindはxlPartで拾い、Leftで前方一致確認を必ず追加。
  • 先頭ゼロや大小文字の違いで漏れる
    • 対策: 比較前にCStr/UCase、必要ならStrConvで半角・全角統一。
  • 行ごとのセルアクセスで遅い
    • 対策: まず範囲を配列へ読み込んでから判定。インデックス化で候補を絞る。
  • 複数回の検索で毎回全走査してしまう
    • 対策: バケット／L文字インデックスを作って再利用。
  • 無限ループ（FindNext）
    • 対策: 最初のアドレスを記録して、戻ったら終了。

例題で練習

'例1：Find＋Leftで前方一致の全件を赤文字
Sub Example_FindPrefixAll()
    Dim rng As Range, hit As Range, first As String, prefix As String
    Set rng = Range("A2:A50000")
    prefix = "PRD"
    Set hit = rng.Find(What:=prefix, LookAt:=xlPart, LookIn:=xlValues)
    If hit Is Nothing Then Exit Sub
    first = hit.Address
    Do
        If Left$(CStr(hit.Value), Len(prefix)) = prefix Then hit.Font.Color = vbRed
        Set hit = rng.FindNext(hit)
    Loop While Not hit Is Nothing And hit.Address <> first
End Sub

'例2：Likeで「ORD*」に一致する行を抽出へコピー
Sub Example_LikePrefixExtract()
    Dim last As Long, r As Long, s As String, outRow As Long
    last = Cells(Rows.Count, "A").End(xlUp).Row: outRow = 2
    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        If s Like "ORD*" Then
            Rows(r).Copy Destination:=Worksheets("抽出").Rows(outRow)
            outRow = outRow + 1
        End If
    Next
End Sub

'例3：インデックス（先頭3文字）で前方一致を高速色付け
Sub Example_Index3PrefixColor()
    Call PrefixIndex_Full  '上で定義したサブルーチンをそのまま利用
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました