Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – CSV検証ツール

Excel VBA
スポンサーリンク

ねらい：CSVの「ヘッダ・型・必須・重複・範囲・書式」を一括検証して、エラーを“見える化”する

CSV取り込み前に“壊れていないか”を機械的にチェックできると事故が激減します。VBAなら“安全読込→ルール定義→行ごと検証→エラーレポート出力”の型で、列変更にも強く、数万行でも短時間で完了します。初心者でも貼って動くテンプレを、例題付きでやさしく解説します。

入力仕様と共通基盤（安全読込・列アクセス・ログ）

シート前提とファイル条件

  • Dataシートは不要。CSVファイルを直接読み込み、配列で処理します。
  • 1行目はヘッダ。区切りはカンマ。改行や引用はExcelのOpenで解決します。

ユーティリティ（貼って動く最小セット）

' ModCsv_Base.bas
Option Explicit

Public Function OpenCsvToArray(ByVal csvPath As String) As Variant
    ' Excelで開いて CurrentRegion を配列化→閉じる（値のみ）
    Dim wb As Workbook, ws As Worksheet
    Set wb = Application.Workbooks.Open(Filename:=csvPath)
    Set ws = wb.Worksheets(1)
    OpenCsvToArray = ws.Range("A1").CurrentRegion.Value
    wb.Close SaveChanges:=False
End Function

Public Sub WriteBlock(ByVal ws As Worksheet, ByVal a As Variant, ByVal startCell As String)
    ws.Range(startCell).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Sub FormatBlock(ByVal ws As Worksheet, ByVal startCell As String)
    With ws.Range(startCell).CurrentRegion
        .Columns.AutoFit
        .Borders.LineStyle = xlContinuous
    End With
End Sub

Public Function ColIndex(ByVal headers As Variant, ByVal name As String) As Long
    Dim c As Long
    For c = 1 To UBound(headers, 2)
        If LCase$(Trim$(CStr(headers(1, c)))) = LCase$(Trim$(name)) Then
            ColIndex = c: Exit Function
        End If
    Next
    ColIndex = 0 ' 見つからない
End Function

Public Function IsEmptyCell(ByVal v As Variant) As Boolean
    IsEmptyCell = (Len(Trim$(CStr(v))) = 0)
End Function
VB

重要部分の深掘り

  • CSVは“開く→CurrentRegion→閉じる”で安全・高速。一切セル操作せず配列で処理します。
  • ヘッダは1行目固定。列アクセスは“名前で検索”にして、順番が変わっても壊れない設計にします。
  • 出力は必ず一括書式適用（罫線・AutoFit）でレビュアーが読みやすい形に整えます。

ルール定義：必須・型・長さ・正規表現・範囲・ユニーク

バリデーションルールを構造体で持つ（初心者に優しい書き方）

' ModCsv_Rules.bas
Option Explicit

Public Type FieldRule
    Name As String        ' 列名（ヘッダと一致）
    Required As Boolean   ' 必須
    TypeName As String    ' "text"/"number"/"date"/"email"/"phone"
    MinLen As Long        ' 最小文字数（テキスト）
    MaxLen As Long        ' 最大文字数（テキスト）
    MinVal As Double      ' 最小値（数値・日付序数）
    MaxVal As Double      ' 最大値（数値・日付序数）
    Pattern As String     ' 正規表現（簡易：Like記法）
    Unique As Boolean     ' ユニーク制約
End Type

Public Function SampleRules() As Variant
    ' 例：受注CSV（OrderDate, Customer, Email, Item, Qty, Price）
    Dim r() As FieldRule: ReDim r(1 To 6)
    r(1) = MakeRule("OrderDate", True, "date", 0, 0, 0, 0, "", False)
    r(2) = MakeRule("Customer", True, "text", 1, 100, 0, 0, "", False)
    r(3) = MakeRule("Email", False, "email", 0, 100, 0, 0, "*@*.*", False)
    r(4) = MakeRule("Item", True, "text", 1, 100, 0, 0, "", False)
    r(5) = MakeRule("Qty", True, "number", 0, 0, 1, 100000, "", False)
    r(6) = MakeRule("Price", True, "number", 0, 0, 0, 100000000, "", False)
    SampleRules = r
End Function

Private Function MakeRule(ByVal name As String, ByVal req As Boolean, ByVal typeName As String, _
                          ByVal minLen As Long, ByVal maxLen As Long, ByVal minVal As Double, ByVal maxVal As Double, _
                          ByVal pattern As String, ByVal unique As Boolean) As FieldRule
    Dim fr As FieldRule
    fr.Name = name: fr.Required = req: fr.TypeName = typeName
    fr.MinLen = minLen: fr.MaxLen = maxLen
    fr.MinVal = minVal: fr.MaxVal = maxVal
    fr.Pattern = pattern: fr.Unique = unique
    MakeRule = fr
End Function
VB

重要部分の深掘り

  • ルールは“列名基準”で定義。順番が変わっても適用できます。
  • 型は最低限の5種に整理。実務で増やすなら TypeName を拡張（URL、郵便番号など）。
  • 正規表現はLike記法を使い、初心者でも「@.*」のような簡易パターンで検証できます。

検証ロジック：行ごとにルール適用、重複・範囲・型の判定

検証の本体（高速・わかりやすい）

' ModCsv_Validate.bas
Option Explicit

Public Sub ValidateCsv(ByVal csvPath As String, ByVal rules As Variant, ByVal outSheet As String)
    Dim data As Variant: data = OpenCsvToArray(csvPath)
    Dim headers As Variant: headers = data ' 1行目がヘッダ

    ' 列名→インデックス
    Dim idx As Object: Set idx = CreateObject("Scripting.Dictionary"): idx.CompareMode = 1
    Dim c As Long
    For c = 1 To UBound(data, 2)
        idx(LCase$(Trim$(CStr(data(1, c))))) = c
    Next

    ' ユニークチェック用の辞書（列ごと）
    Dim uniq As Object: Set uniq = CreateObject("Scripting.Dictionary"): uniq.CompareMode = 1
    Dim i As Long
    For i = LBound(rules) To UBound(rules)
        If rules(i).Unique Then
            Set uniq(rules(i).Name) = CreateObject("Scripting.Dictionary")
            uniq(rules(i).Name).CompareMode = 1
        End If
    Next

    ' エラー出力配列: Row, Field, Issue, Value
    Dim out() As Variant: ReDim out(1 To 1, 1 To 4)
    out(1, 1) = "Row": out(1, 2) = "Field": out(1, 3) = "Issue": out(1, 4) = "Value"
    Dim rowsOut As Long: rowsOut = 1

    Dim r As Long
    For r = 2 To UBound(data, 1)
        For i = LBound(rules) To UBound(rules)
            Dim col As Long: col = ColIndex(headers, rules(i).Name)
            If col = 0 Then
                rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
                out(rowsOut, 1) = r: out(rowsOut, 2) = rules(i).Name: out(rowsOut, 3) = "Missing header": out(rowsOut, 4) = ""
                GoTo NextField
            End If

            Dim v As Variant: v = data(r, col)
            Dim vText As String: vText = Trim$(CStr(v))

            ' 必須
            If rules(i).Required And IsEmptyCell(v) Then
                AddErr out, rowsOut, r, rules(i).Name, "Required", vText
                GoTo NextField
            End If

            ' 型チェック
            If Not IsEmptyCell(v) Then
                Select Case LCase$(rules(i).TypeName)
                    Case "number": If Not IsNumeric(v) Then AddErr out, rowsOut, r, rules(i).Name, "Not number", vText
                    Case "date": If Not IsDate(v) Then AddErr out, rowsOut, r, rules(i).Name, "Not date", vText
                    Case "email": If InStr(1, vText, "@") = 0 Or InStrRev(vText, ".") = 0 Then AddErr out, rowsOut, r, rules(i).Name, "Invalid email", vText
                    Case "phone": If Not vText Like "*#*" Then AddErr out, rowsOut, r, rules(i).Name, "Invalid phone", vText
                    Case "text": ' 何もしない
                End Select
            End If

            ' 長さ
            If rules(i).MinLen > 0 And Len(vText) < rules(i).MinLen Then AddErr out, rowsOut, r, rules(i).Name, "Too short", vText
            If rules(i).MaxLen > 0 And Len(vText) > rules(i).MaxLen Then AddErr out, rowsOut, r, rules(i).Name, "Too long", vText

            ' 範囲（数値/日付）
            If rules(i).TypeName = "number" And Not IsEmptyCell(v) Then
                If rules(i).MinVal <> 0 Or rules(i).MaxVal <> 0 Then
                    Dim num As Double: num = CDbl(v)
                    If rules(i).MinVal <> 0 And num < rules(i).MinVal Then AddErr out, rowsOut, r, rules(i).Name, "Below min", vText
                    If rules(i).MaxVal <> 0 And num > rules(i).MaxVal Then AddErr out, rowsOut, r, rules(i).Name, "Above max", vText
                End If
            ElseIf rules(i).TypeName = "date" And Not IsEmptyCell(v) Then
                Dim dt As Date: dt = CDate(v)
                If rules(i).MinVal <> 0 And dt < rules(i).MinVal Then AddErr out, rowsOut, r, rules(i).Name, "Before min date", vText
                If rules(i).MaxVal <> 0 And dt > rules(i).MaxVal Then AddErr out, rowsOut, r, rules(i).Name, "After max date", vText
            End If

            ' パターン（Like）
            If Len(rules(i).Pattern) > 0 And Not IsEmptyCell(v) Then
                If Not (vText Like rules(i).Pattern) Then AddErr out, rowsOut, r, rules(i).Name, "Pattern mismatch", vText
            End If

            ' ユニーク
            If rules(i).Unique And Not IsEmptyCell(v) Then
                Dim k As String: k = LCase$(vText)
                If uniq(rules(i).Name).Exists(k) Then
                    AddErr out, rowsOut, r, rules(i).Name, "Duplicate", vText
                Else
                    uniq(rules(i).Name)(k) = True
                End If
            End If

NextField:
        Next i
    Next r

    ' 出力
    Dim ws As Worksheet
    On Error Resume Next: Set ws = Worksheets(outSheet): On Error GoTo 0
    If ws Is Nothing Then Set ws = Worksheets.Add: ws.Name = outSheet Else ws.Cells.Clear

    WriteBlock ws, out, "A1"
    FormatBlock ws, "A1"
End Sub

Private Sub AddErr(ByRef out() As Variant, ByRef rowsOut As Long, ByVal r As Long, ByVal field As String, ByVal issue As String, ByVal vText As String)
    rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
    out(rowsOut, 1) = r
    out(rowsOut, 2) = field
    out(rowsOut, 3) = issue
    out(rowsOut, 4) = vText
End Sub
VB

重要部分の深掘り

  • ループは“行→ルール”の二重でシンプル。各チェックは早期にエラー追加し、次の項目へ進みます。
  • ユニーク判定は“列ごとの辞書”で高速。大量件数でも一瞬です。
  • パターンはLikeで十分な場面が多い。高度な正規表現が必要なら、後から拡張（VBScript.RegExp）可能です。

拡張オプション：ヘッダ検証・必須列の存在・サマリー出力

追加チェックと要約レポート

' ModCsv_Extras.bas
Option Explicit

Public Sub CheckHeaders(ByVal data As Variant, ByVal rules As Variant, ByRef out() As Variant, ByRef rowsOut As Long)
    Dim need As Object: Set need = CreateObject("Scripting.Dictionary"): need.CompareMode = 1
    Dim i As Long: For i = LBound(rules) To UBound(rules): need(rules(i).Name) = False: Next
    Dim c As Long
    For c = 1 To UBound(data, 2)
        Dim name As String: name = Trim$(CStr(data(1, c)))
        If need.Exists(name) Then need(name) = True
    Next
    Dim k As Variant
    For Each k In need.Keys
        If Not need(k) Then
            rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 4)
            out(rowsOut, 1) = 1: out(rowsOut, 2) = CStr(k): out(rowsOut, 3) = "Header missing": out(rowsOut, 4) = ""
        End If
    Next
End Sub

Public Sub SummarizeErrors(ByVal outSheet As String)
    Dim ws As Worksheet: Set ws = Worksheets(outSheet)
    Dim a As Variant: a = ws.Range("A1").CurrentRegion.Value
    If UBound(a, 1) < 2 Then Exit Sub

    Dim dIssue As Object: Set dIssue = CreateObject("Scripting.Dictionary")
    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim key As String: key = CStr(a(r, 2)) & " | " & CStr(a(r, 3)) ' Field | Issue
        dIssue(key) = IIf(dIssue.Exists(key), dIssue(key) + 1, 1)
    Next

    Dim out() As Variant: ReDim out(1 To dIssue.Count + 1, 1 To 2)
    out(1, 1) = "Field | Issue": out(1, 2) = "Count"
    Dim i As Long: i = 2, k As Variant
    For Each k In dIssue.Keys
        out(i, 1) = k: out(i, 2) = dIssue(k): i = i + 1
    Next

    WriteBlock ws, out, "G1"
    FormatBlock ws, "G1"
    ws.Columns("H").NumberFormatLocal = "#,##0"
End Sub
VB

重要部分の深掘り

  • “ヘッダが存在しない”は最大級のエラー。最初に検知して直すべきです。
  • サマリー（Field | Issue | Count）を右側に出すと、どこが壊れているか一目で把握できます。

例題の通し方：ルール定義→検証→サマリー→出力

実行テンプレ（貼って動く）

' ModCsv_Example.bas
Option Explicit

Public Sub Run_CsvValidation()
    Dim csvPath As String: csvPath = ThisWorkbook.Path & "\orders.csv" ' 例：同フォルダに置く
    Dim rules As Variant: rules = SampleRules()

    ' メイン検証
    ValidateCsv csvPath, rules, "CSV_Errors"

    ' 要約
    SummarizeErrors "CSV_Errors"

    MsgBox "CSV検証が完了しました。エラー一覧と要約を確認してください。", vbInformation
End Sub
VB

期待動作：orders.csvを読み込み、CSV_Errorsシートに「Row, Field, Issue, Value」のエラー一覧が出ます。右側に“Field | Issue | Count”の集計が出て、修正の優先度がすぐ決められます。

落とし穴と対策（深掘り）

文字列日付・文字数値の型崩れ

型チェックで弾くだけでなく、前処理（ToDate/ToNumber）に落としてから再検証する運用も有効です。

必須列が欠けているのに処理を続行

ヘッダ検証で“Missing header”を最初に出し、修正が終わるまで取り込みを保留にするのが安全です。

パターンが厳しすぎて過剰検知

Likeのパターンは“緩め”から始め、現場の誤検知率を見て精密化します（例：メールは最低限“@と.”の存在チェック）。

ユニーク制約の誤判定

前後空白・大小の揺れで重複を見逃します。ユニーク判定前に Trim＋LCase を掛ける（本テンプレは vText を小文字化しています）。

セル逐次処理で遅い

配列に載せて検証→一括書き戻しが鉄則。数万行でも短時間で完了し、画面が固まりません。

まとめ：ルールを“列名”で持ち、型・必須・範囲・重複を一撃で見える化する

  • 入力は配列化して安全に。ルールは列名基準で、順番変更に強くする。
  • 検証は“必須→型→長さ→範囲→パターン→ユニーク”の順で早期にエラー化。
  • エラーは「Row, Field, Issue, Value」で出し、要約を併記。修正の優先度が即決できます。

スポンサーリンク
タイトルとURLをコピーしました