Excel VBA 逆引き集 | 正規表現検索

Excel VBA
スポンサーリンク

正規表現検索

複雑な「パターンで探す・抽出する・置換する」なら正規表現が最短で強力。メール、電話番号、郵便番号、コード形式、日付の抽出や検証を、初心者向けに安全テンプレと例題でまとめます。

事前準備（2つの使い方）

  • 手早い方法（Late Binding）：参照設定不要Dim re As Object Set re = CreateObject("VBScript.RegExp")
    • そのまま動く。配布に向く。
  • 補完が効く方法（Early Binding）：参照設定あり
    • VBEの「ツール」→「参照設定」→「Microsoft VBScript Regular Expressions 5.5」にチェック。
    Dim re As RegExp Set re = New RegExp
  • 基本プロパティ（よく使うだけ）
    • Pattern: 正規表現文字列
    • IgnoreCase: 大文字小文字を無視（True/False）
    • Global: 全件取得・置換（True）、最初の1件のみ（False）
    • 主な関数: Test（一致有無）、Execute（一致一覧）、Replace（置換）

最短テンプレ（一致判定・抽出・置換）

'1) 一致判定（Test）
Sub Regex_Test()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "^[A-Z]{3}-\d{4}$"    '例：ABC-1234
    re.IgnoreCase = False: re.Global = False
    If re.Test("ABC-1234") Then
        MsgBox "一致しました"
    Else
        MsgBox "不一致です"
    End If
End Sub

'2) 全ヒット抽出（Execute）
Sub Regex_Execute_All()
    Dim re As Object, ms As Object, m As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\b\d{3}-\d{4}\b"     '例：郵便番号 123-4567
    re.Global = True: re.IgnoreCase = True
    Set ms = re.Execute("住所:123-4567 他 987-6543")
    For Each m In ms
        Debug.Print m.Value            'ヒット文字列
    Next
End Sub

'3) 置換（Replace）
Sub Regex_Replace_Mask()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{3})-(\d{4})"
    re.Global = True
    Dim s As String
    s = "郵便:123-4567, 987-6543"
    Debug.Print re.Replace(s, "$1-****") '→ 123-****, 987-****
End Sub
VB
  • ポイント:
    • ^（先頭）、$（末尾）、\d（数字）、\w（英数下線）、{n}（回数）、[]（文字クラス）、()（グループ）、|（OR）を覚えると実務は大体いけます。
    • 置換の $1 は1番目のグループ参照。

セル範囲を正規表現で検索（全件列挙）

Sub Regex_FindAll_InRange()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\bERROR\d{3}\b" '例：ERROR123 のようなタグ
    re.IgnoreCase = True: re.Global = False

    Dim last As Long, r As Long, s As String
    last = Cells(Rows.Count, "A").End(xlUp).Row

    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        If re.Test(s) Then
            Cells(r, "A").Font.Color = vbRed
        End If
    Next
End Sub
VB
  • ポイント: 全件抽出（Execute）で部分ごと取りたい場合は、各セルで re.Execute(s) を回して For Each m In ms で拾う。

抽出シートへコピー（複数ヒット対応）

Sub Regex_ExtractToSheet()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "\b[A-Z]{3}-\d{4}\b" 'コードABC-1234
    re.Global = True: re.IgnoreCase = False

    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim out As Worksheet: Set out = Worksheets("抽出")
    Dim outRow As Long: outRow = 2

    Dim r As Long, s As String, ms As Object, m As Object
    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        Set ms = re.Execute(s)
        If ms.Count > 0 Then
            For Each m In ms
                out.Cells(outRow, 1).Value = m.Value
                out.Cells(outRow, 2).Value = r         '元の行番号
                outRow = outRow + 1
            Next
        End If
    Next
End Sub
VB
  • ポイント: 1セルに複数パターンがあるケースにも強い。

代表パターン集（コピペOK）

  • メールアドレス（ゆるめ） 
re.Pattern = "^[\w\.\-]+@[\w\.\-]+\.\w{2,}$"
VB
  • 電話番号（ハイフン区切り 2-4-4 または 3-3-4） 
re.Pattern = "\b(?:\d{2,4}-\d{2,4}-\d{4})\b"
VB
  • 郵便番号（123-4567） 
re.Pattern = "\b\d{3}-\d{4}\b"
VB
  • 日付（YYYY/MM/DD または YYYY-MM-DD） 
re.Pattern = "\b\d{4}[-/]\d{1,2}[-/]\d{1,2}\b"
VB
  • 英大字3-数字4（ABC-1234） 
re.Pattern = "\b[A-Z]{3}-\d{4}\b"
VB
  • 備考: 厳密検証が必要なら月/日の妥当性チェックを追加で行う（例：分岐または後段でDateValueをTry）。

グループで部分取り（キャプチャを使う）

Sub Regex_CaptureGroups()
    Dim re As Object, ms As Object, m As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{3})-(\d{4})"
    re.Global = True

    Set ms = re.Execute("郵便:123-4567 他 987-6543")
    For Each m In ms
        Debug.Print "全部=" & m.Value & ", 前半=" & m.SubMatches(0) & ", 後半=" & m.SubMatches(1)
    Next
End Sub
VB
  • ポイント: SubMatches(index) で括弧の中身が取れる。

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

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

Sub Regex_SafeWrap_End()
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
  • 使い方: 前後に挟むだけで体感速度が段違い。エラー時は On Error で必ず復帰。

よくある落とし穴と対策

  • 改行をまたぐ一致が取れない
    • 対策: 1セルに改行がある場合は正規表現では行頭・行末の扱いが変わる。必要なら文字列を事前に Replace(s, vbCrLf, " ") などで正規化。
  • 日本語と記号の混在で過剰ヒット
    • 対策: 境界 \b は英数字境界中心。日本語混在時は前後を記号・空白で囲うパターンにする、または (^|[^A-Za-z0-9])…([^A-Za-z0-9]|$) のように明示境界を定義。
  • 大文字小文字で漏れる
    • 対策: IgnoreCase=True。厳密に区別したい列だけ False に。
  • 最初の1件しか取れない
    • 対策: Global=True を忘れない。全件抽出や全置換は必須設定。
  • 過度に複雑なパターンで遅い
    • 対策: まず範囲を絞る（対象列やフィルタで）→正規表現を簡素化→前処理で正規化（空白や記号除去）すると速く安定。

例題で練習

'例1：A列からメールを抽出して「抽出」シートへ一覧
Sub Example_ExtractEmails()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "[\w\.\-]+@[\w\.\-]+\.\w{2,}"
    re.Global = True: re.IgnoreCase = True

    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim out As Worksheet: Set out = Worksheets("抽出")
    Dim outRow As Long: outRow = 2

    Dim r As Long, s As String, ms As Object, m As Object
    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        Set ms = re.Execute(s)
        For Each m In ms
            out.Cells(outRow, 1).Value = m.Value
            out.Cells(outRow, 2).Value = r
            outRow = outRow + 1
        Next
    Next
End Sub

'例2：A列の電話番号を「市外局番-****-****」でマスク
Sub Example_MaskPhones()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{2,4})-(\d{2,4})-(\d{4})"
    re.Global = True

    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Long, s As String
    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        Cells(r, "A").Value = re.Replace(s, "$1-****-****")
    Next
End Sub

'例3：行内の「YYYY/MM/DD」を検証後、B列へ日付型で格納
Sub Example_ExtractDateToB()
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "(\d{4})[-/](\d{1,2})[-/](\d{1,2})"
    re.Global = False

    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim r As Long, s As String, ms As Object, m As Object, y As Integer, mth As Integer, d As Integer
    For r = 2 To last
        s = CStr(Cells(r, "A").Value)
        Set ms = re.Execute(s)
        If ms.Count > 0 Then
            Set m = ms(0)
            y = CInt(m.SubMatches(0)): mth = CInt(m.SubMatches(1)): d = CInt(m.SubMatches(2))
            On Error Resume Next
            Cells(r, "B").Value = DateSerial(y, mth, d) '妥当でない日付はエラーでスキップ
            On Error GoTo 0
        End If
    Next
End Sub
VB
スポンサーリンク
タイトルとURLをコピーしました