Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 仕様チェックツール

Excel VBA
スポンサーリンク

ねらい：シートやテーブルの「仕様（列名・型・必須・制約・相互参照）」を一括で検査して、逸脱をすぐに見つける

仕様チェックは「定義した通りにデータが作られているか」を機械的に見張る仕組みです。列名のズレ、型崩れ、必須欠損、範囲逸脱、ユニーク違反、クロス参照不整合（マスタにないID）などを“同じルール”で毎回チェックすれば、取り込み・集計・出力の事故がグッと減ります。VBAなら“仕様を宣言→配列で読み込み→ルール適用→エラーレポート＋要約”の型で、初心者でも貼って動くツールにできます。

仕様の持ち方：列定義・制約・相互参照を一目でわかる構造体に

仕様構造体（FieldSpec と SheetSpec）

' ModSpec_Definition.bas
Option Explicit

Public Type FieldSpec
    Name As String        ' 列名（ヘッダ）
    Required As Boolean   ' 必須
    TypeName As String    ' "text"/"number"/"date"/"email"/"id"
    MinLen As Long        ' テキスト最小長
    MaxLen As Long        ' テキスト最大長
    MinVal As Double      ' 数値/日付下限
    MaxVal As Double      ' 数値/日付上限
    Pattern As String     ' Likeパターン（例 "*@*.*"）
    Unique As Boolean     ' ユニーク制約
    RefSheet As String    ' 参照先シート（IDの存在チェック用）
    RefField As String    ' 参照先フィールド名（ヘッダ）
End Type

Public Type SheetSpec
    SheetName As String
    Fields() As FieldSpec
End Type

Public Function MakeField( _
    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, _
    Optional ByVal refSheet As String = "", Optional ByVal refField As String = "" _
) As FieldSpec
    Dim f As FieldSpec
    f.Name = name: f.Required = req: f.TypeName = typeName
    f.MinLen = minLen: f.MaxLen = maxLen
    f.MinVal = minVal: f.MaxVal = maxVal
    f.Pattern = pattern: f.Unique = unique
    f.RefSheet = refSheet: f.RefField = refField
    MakeField = f
End Function
VB

重要部分の深掘り

  • 仕様は“列名ベース”で宣言: 順番が変わっても評価できます。ヘッダ名は運用で固定し、変えるときは仕様とデータを同時更新。
  • RefSheet/RefFieldで相互参照を明示: IDの存在チェックを“仕様で宣言”できるようにすると、参照整合の漏れを防げます。
  • 型は厳選: text/number/date/email/idから始め、必要に応じて拡張（URL、郵便番号など）。

共通基盤：安全読込・列インデックス・フォーマット・参照辞書

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

' ModSpec_Base.bas
Option Explicit

Public Function ReadRegion(ws As Worksheet, Optional topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

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

Public Sub FormatBlock(ws As Worksheet, 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

Public Function BuildRefDict(ByVal refSheet As String, ByVal refField As String) As Object
    Dim ws As Worksheet: Set ws = Worksheets(refSheet)
    Dim a As Variant: a = ReadRegion(ws)
    Dim col As Long: col = ColIndex(a, refField)
    Dim d As Object: Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
    If col = 0 Then Set BuildRefDict = d: Exit Function
    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim k As String: k = LCase$(Trim$(CStr(a(r, col))))
        If Len(k) > 0 Then d(k) = True
    Next
    Set BuildRefDict = d
End Function
VB

重要部分の深掘り

  • ColIndexはヘッダ一致で列を取得: 列順の変更に強く、コードが壊れません。
  • 参照辞書は事前構築: “顧客マスタの顧客ID存在チェック”などを高速に判定できます。
  • 出力は一括書式: 罫線とAutoFitでレビュー性を標準化。

検証ロジック：必須・型・長さ・範囲・パターン・ユニーク・参照整合

仕様チェックの本体（行×フィールドで評価）

' ModSpec_Validate.bas
Option Explicit

Public Sub ValidateSheet(ByVal spec As SheetSpec, ByVal outSheet As String)
    Dim ws As Worksheet: Set ws = Worksheets(spec.SheetName)
    Dim data As Variant: data = ReadRegion(ws)

    ' ヘッダ存在チェック
    Dim i As Long
    Dim out() As Variant: ReDim out(1 To 1, 1 To 5)
    out(1, 1) = "Row": out(1, 2) = "Field": out(1, 3) = "Issue": out(1, 4) = "Value": out(1, 5) = "Sheet"

    Dim rowsOut As Long: rowsOut = 1
    For i = LBound(spec.Fields) To UBound(spec.Fields)
        If ColIndex(data, spec.Fields(i).Name) = 0 Then
            AddErr out, rowsOut, 1, spec.Fields(i).Name, "Missing header", "", spec.SheetName
        End If
    Next

    ' 列名→インデックス
    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 refDicts As Object: Set refDicts = CreateObject("Scripting.Dictionary")
    For i = LBound(spec.Fields) To UBound(spec.Fields)
        If Len(spec.Fields(i).RefSheet) > 0 And Len(spec.Fields(i).RefField) > 0 Then
            Dim key As String: key = spec.Fields(i).RefSheet & "|" & spec.Fields(i).RefField
            If Not refDicts.Exists(key) Then Set refDicts(key) = BuildRefDict(spec.Fields(i).RefSheet, spec.Fields(i).RefField)
        End If
    Next

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

    ' 行ごとチェック
    Dim r As Long
    For r = 2 To UBound(data, 1)
        For i = LBound(spec.Fields) To UBound(spec.Fields)
            Dim col As Long: col = ColIndex(data, spec.Fields(i).Name)
            If col = 0 Then GoTo NextField

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

            ' 必須
            If spec.Fields(i).Required And IsEmptyCell(v) Then
                AddErr out, rowsOut, r, spec.Fields(i).Name, "Required", vt, spec.SheetName
                GoTo NextField
            End If

            ' 型
            If Not IsEmptyCell(v) Then
                Select Case LCase$(spec.Fields(i).TypeName)
                    Case "number": If Not IsNumeric(v) Then AddErr out, rowsOut, r, spec.Fields(i).Name, "Not number", vt, spec.SheetName
                    Case "date": If Not IsDate(v) Then AddErr out, rowsOut, r, spec.Fields(i).Name, "Not date", vt, spec.SheetName
                    Case "email": If InStr(1, vt, "@") = 0 Or InStrRev(vt, ".") = 0 Then AddErr out, rowsOut, r, spec.Fields(i).Name, "Invalid email", vt, spec.SheetName
                    Case "id": If Len(vt) = 0 Then AddErr out, rowsOut, r, spec.Fields(i).Name, "Invalid id", vt, spec.SheetName
                    Case "text": ' pass
                End Select
            End If

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

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

            ' パターン
            If Len(spec.Fields(i).Pattern) > 0 And Not IsEmptyCell(v) Then
                If Not (vt Like spec.Fields(i).Pattern) Then AddErr out, rowsOut, r, spec.Fields(i).Name, "Pattern mismatch", vt, spec.SheetName
            End If

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

            ' 参照整合
            If Len(spec.Fields(i).RefSheet) > 0 And Len(spec.Fields(i).RefField) > 0 And Not IsEmptyCell(v) Then
                Dim refKey As String: refKey = spec.Fields(i).RefSheet & "|" & spec.Fields(i).RefField
                If refDicts.Exists(refKey) Then
                    If Not refDicts(refKey).Exists(LCase$(vt)) Then
                        AddErr out, rowsOut, r, spec.Fields(i).Name, "Missing in " & refKey, vt, spec.SheetName
                    End If
                End If
            End If

NextField:
        Next i
    Next r

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

    WriteBlock w, out, "A1"
    FormatBlock w, "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 valText As String, ByVal sheetName As String)
    rowsOut = rowsOut + 1: ReDim Preserve out(1 To rowsOut, 1 To 5)
    out(rowsOut, 1) = r
    out(rowsOut, 2) = field
    out(rowsOut, 3) = issue
    out(rowsOut, 4) = valText
    out(rowsOut, 5) = sheetName
End Sub
VB

重要部分の深掘り

  • 検証順序を固定: 必須→型→長さ→範囲→パターン→ユニーク→参照整合。早期にエラー登録して次へ進み、長い分岐を避けます。
  • 相互参照は“辞書化”で高速: マスタにないIDを即検出できます。大量データでもストレスなく動きます。
  • エラーレイアウトを標準化: Row/Field/Issue/Value/Sheetの5列で“どこ・何が・どう壊れているか”を明確に。

要約レポートと複数シート検証：壊れ方を俯瞰して優先度を決める

エラー要約（Field | Issue | Count）と複数シート走査

' ModSpec_Summary.bas
Option Explicit

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 d As Object: Set d = CreateObject("Scripting.Dictionary")
    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim key As String: key = CStr(a(r, 5)) & " | " & CStr(a(r, 2)) & " | " & CStr(a(r, 3)) ' Sheet | Field | Issue
        d(key) = IIf(d.Exists(key), d(key) + 1, 1)
    Next

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

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

Public Sub ValidateMultipleSheets(ByVal specs() As SheetSpec, ByVal outSheet As String)
    Dim i As Long
    Dim firstOut As Boolean: firstOut = True
    For i = LBound(specs) To UBound(specs)
        ValidateSheet specs(i), outSheet
        If firstOut Then
            SummarizeErrors outSheet
            firstOut = False
        Else
            SummarizeErrors outSheet
        End If
    Next
End Sub
VB

重要部分の深掘り

  • 要約で“壊れの山”を見える化: 修正の優先順位（必須欠損＞ヘッダ欠落＞型違い…）を即決できます。
  • 複数シート検証を一括: 受注、顧客マスタ、商品マスタなどを同じルール型で順番にチェックできます。

例題の通し方：受注とマスタの仕様を宣言→検証→要約レポート

仕様定義と実行テンプレ（貼って動く）

' ModSpec_Example.bas
Option Explicit

Public Sub Run_SpecCheck()
    ' 1) 受注シート仕様
    Dim ord As SheetSpec
    ord.SheetName = "Orders"
    ReDim ord.Fields(1 To 6)
    ord.Fields(1) = MakeField("OrderDate", True, "date", 0, 0, 0, 0, "", False)
    ord.Fields(2) = MakeField("OrderID", True, "id", 0, 50, 0, 0, "", True)
    ord.Fields(3) = MakeField("CustomerID", True, "id", 0, 50, 0, 0, "", False, "Customers", "CustomerID")
    ord.Fields(4) = MakeField("ItemID", True, "id", 0, 50, 0, 0, "", False, "Products", "ItemID")
    ord.Fields(5) = MakeField("Qty", True, "number", 0, 0, 1, 100000, "", False)
    ord.Fields(6) = MakeField("Price", True, "number", 0, 0, 0, 100000000, "", False)

    ' 2) 顧客マスタ仕様
    Dim cus As SheetSpec
    cus.SheetName = "Customers"
    ReDim cus.Fields(1 To 3)
    cus.Fields(1) = MakeField("CustomerID", True, "id", 0, 50, 0, 0, "", True)
    cus.Fields(2) = MakeField("CustomerName", True, "text", 1, 100, 0, 0, "", False)
    cus.Fields(3) = MakeField("Email", False, "email", 0, 100, 0, 0, "*@*.*", False)

    ' 3) 商品マスタ仕様
    Dim prd As SheetSpec
    prd.SheetName = "Products"
    ReDim prd.Fields(1 To 3)
    prd.Fields(1) = MakeField("ItemID", True, "id", 0, 50, 0, 0, "", True)
    prd.Fields(2) = MakeField("ItemName", True, "text", 1, 100, 0, 0, "", False)
    prd.Fields(3) = MakeField("UnitPrice", True, "number", 0, 0, 0, 100000000, "", False)

    ' 4) 実行：複数シートを検証
    Dim specs(1 To 3) As SheetSpec
    specs(1) = ord: specs(2) = cus: specs(3) = prd

    ValidateMultipleSheets specs, "SpecErrors"

    MsgBox "仕様チェックが完了しました。SpecErrorsでエラーと要約をご確認ください。", vbInformation
End Sub
VB

期待動作：Orders/Customers/Productsの各シートを仕様通りに検証し、SpecErrorsに「Row/Field/Issue/Value/Sheet」が一覧で出ます。右側に“Sheet | Field | Issue | Count”の要約が出て、どのシートのどの項目が壊れているか一目で把握できます。

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

ヘッダ名の微妙な違いで“見つからない”判定が頻発

ヘッダ名の運用を標準化し、仕様定義とシートの表記を必ず一致させる。不要な空白・大小違いはTrim＋小文字化で吸収します。

分母ゼロ・空値で過剰な範囲/型エラー

検証順序を“必須→型→範囲”に固定。空値は“必須で落とす”、型が不正なら“範囲チェックをスキップ”で誤検知を避けます。

相互参照の辞書が古い（マスタ更新漏れ）

検証前に必ず最新マスタを読み込む導線に。辞書は検証開始時にその場で再構築し、古いキャッシュを使わない。

ユニーク制約の誤判定（大小・空白の揺れ）

ユニーク判定は必ず Trim＋LCase の正規化後に評価。空文字はユニーク対象外にする運用も現場で検討。

セル逐次処理で遅い

全工程を“配列で計算→一括書き戻し”。辞書を使った参照整合で数万行でも短時間に完了します。

まとめ：仕様を宣言し、同じ順序で機械的に検証する“型”を作る

  • 仕様は列名ベースで宣言し、必須・型・長さ・範囲・パターン・ユニーク・相互参照を含める。
  • 検証は宣言通りの順序で実行し、エラーは「Row/Field/Issue/Value/Sheet」に統一して出す。
  • 要約を併記して“壊れの山”を俯瞰し、修正の優先度をすぐ決める。

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