Excel VBA | Excel データチェック自動ツール

Excel VBA VBA
スポンサーリンク
' =====================================================
' Excel データチェック自動ツール — 完成版
' 説明: このモジュールは業務で使える「データチェック自動ツール」です。
' - 指定したシートのデータをスキャンして検査ルールに従いエラー/警告を抽出
' - 問題箇所をレポートシートに出力
' - 各種ルールはモジュール上の「設定」部分で簡単に変更可能
' 使い方:
' 1. このコードを標準モジュールに貼り付ける（例: Module1）
' 2. データは 「Data」 という名前のシートに下記のようなヘッダーを用意する
'    例: A:ID, B:Name, C:Date, D:Amount, E:Status
' 3. 設定を必要に応じて編集してから、RunDataCheck を実行
' =====================================================

Option Explicit

' --------------------
' === 設定セクション ===
' --------------------
' データシート名
Private Const DATA_SHEET_NAME As String = "Data"
' レポート出力先シート名（既存なら上書き）
Private Const REPORT_SHEET_NAME As String = "DataCheck_Report"
' ヘッダー行番号（0 ではなく 1 ベース）
Private Const HEADER_ROW As Long = 1
'
' 必須カラム（ヘッダー名を指定）
Private RequiredColumns As Variant
' 一意キーとしてチェックするカラム名（重複を検出）
Private UniqueKeyColumns As Variant
'
' データ型チェック（カラム名 -> 種類）
' 支持される型: "Long", "Double", "Date", "String"
Private TypeChecks As Variant
'
' 範囲チェック（カラム名 -> {min, max}）
Private RangeChecks As Variant
'
' 値集合チェック（カラム名 -> Array of allowed values）
Private AllowedValues As Variant
'
' 初期化（デフォルト設定）
Private Sub InitConfig()
    RequiredColumns = Array("ID", "Name", "Date", "Amount")
    UniqueKeyColumns = Array("ID")

    TypeChecks = Array(Array("ID", "Long"), _
                       Array("Name", "String"), _
                       Array("Date", "Date"), _
                       Array("Amount", "Double"), _
                       Array("Status", "String"))

    RangeChecks = Array(Array("Amount", 0, 1000000)) ' Amount は 0〜1,000,000

    AllowedValues = Array(Array("Status", Array("Open", "Closed", "Pending")))
End Sub

' --------------------
' === 実行メイン関数 ===
' --------------------
Public Sub RunDataCheck()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sh As Worksheet

    On Error GoTo ErrHandler

    InitConfig

    Set sh = wb.Worksheets(DATA_SHEET_NAME)

    Dim headerMap As Object: Set headerMap = BuildHeaderMap(sh, HEADER_ROW)
    If headerMap.Count = 0 Then
        MsgBox "ヘッダーが見つかりません。シート名・ヘッダー行を確認してください。", vbExclamation
        Exit Sub
    End If

    Dim lastRow As Long: lastRow = GetLastRow(sh)
    If lastRow <= HEADER_ROW Then
        MsgBox "データが存在しません。", vbInformation
        Exit Sub
    End If

    ' レポートシート準備
    Dim rpt As Worksheet: Set rpt = PrepareReportSheet(wb)
    Dim rptRow As Long: rptRow = 2 ' ヘッダー分を避ける

    ' 一意キー用ディクショナリ
    Dim dictKeys As Object: Set dictKeys = CreateObject("Scripting.Dictionary")

    ' ループ処理（行ごと）
    Dim r As Long
    For r = HEADER_ROW + 1 To lastRow
        Dim issues As Collection: Set issues = New Collection

        ' 必須チェック
        PerformRequiredCheck sh, headerMap, r, issues

        ' 型チェック
        PerformTypeChecks sh, headerMap, r, issues

        ' 範囲チェック
        PerformRangeChecks sh, headerMap, r, issues

        ' 値集合チェック
        PerformAllowedValueChecks sh, headerMap, r, issues

        ' 一意キーチェック
        PerformUniqueKeyChecks sh, headerMap, r, dictKeys, issues

        ' カスタムチェック: ここに業務ロジックを追加できます
        ' 例: 日付が未来日になっていないか、金額がマイナスでないか など
        PerformCustomChecks sh, headerMap, r, issues

        ' もし issues があればレポートに書き出す
        If issues.Count > 0 Then
            Dim i As Long
            For i = 1 To issues.Count
                rpt.Cells(rptRow, 1).Value = r ' 元の行番号
                rpt.Cells(rptRow, 2).Value = issues(i) ' メッセージ
                rptRow = rptRow + 1
            Next i
        End If
    Next r

    ' レポート整形
    FormatReportSheet rpt

    MsgBox "データチェックが完了しました。レポート: " & REPORT_SHEET_NAME, vbInformation
    Exit Sub

ErrHandler:
    MsgBox "実行中にエラーが発生しました: " & Err.Description, vbCritical
End Sub

' --------------------
' === ヘルパ関数 ===
' --------------------
' ヘッダー名->列番号 を作る
Private Function BuildHeaderMap(sh As Worksheet, headerRow As Long) As Object
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim c As Long, lastCol As Long
    lastCol = sh.Cells(headerRow, sh.Columns.Count).End(xlToLeft).Column
    For c = 1 To lastCol
        Dim h As String: h = Trim(CStr(sh.Cells(headerRow, c).Value))
        If Len(h) > 0 Then dict(LCase(h)) = c
    Next c
    Set BuildHeaderMap = dict
End Function

' 最終行取得（A列基準）
Private Function GetLastRow(sh As Worksheet) As Long
    GetLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
End Function

' レポートシートを作る（存在する場合はクリア）
Private Function PrepareReportSheet(wb As Workbook) As Worksheet
    Dim rpt As Worksheet
    On Error Resume Next
    Set rpt = wb.Worksheets(REPORT_SHEET_NAME)
    On Error GoTo 0

    If Not rpt Is Nothing Then
        Application.DisplayAlerts = False
        rpt.Delete
        Application.DisplayAlerts = True
    End If

    Set rpt = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
    rpt.Name = REPORT_SHEET_NAME

    ' ヘッダー
    rpt.Cells(1, 1).Value = "Row"
    rpt.Cells(1, 2).Value = "Issue"
    rpt.Cells(1, 3).Value = "Sheet"
    rpt.Cells(1, 4).Value = "CheckedAt"
    rpt.Cells(1, 5).Value = "Extra"

    Set PrepareReportSheet = rpt
End Function

' レポート整形
Private Sub FormatReportSheet(rpt As Worksheet)
    With rpt
        .Columns("A:E").AutoFit
        .Rows(1).Font.Bold = True
        .Cells(2, 4).Resize(.Rows.Count - 1, 1).Value = Now
    End With
End Sub

' --------------------
' === 各チェック関数 ===
' --------------------
Private Sub PerformRequiredCheck(sh As Worksheet, headerMap As Object, r As Long, issues As Collection)
    Dim i As Long
    For i = LBound(RequiredColumns) To UBound(RequiredColumns)
        Dim colName As String: colName = RequiredColumns(i)
        Dim key As String: key = LCase(colName)
        If Not headerMap.Exists(key) Then
            issues.Add "必須カラムが見つかりません: " & colName
        Else
            Dim colNum As Long: colNum = headerMap(key)
            If Trim(CStr(sh.Cells(r, colNum).Value)) = "" Then
                issues.Add "必須値欠落: '" & colName & "' が空です"
            End If
        End If
    Next i
End Sub

Private Sub PerformTypeChecks(sh As Worksheet, headerMap As Object, r As Long, issues As Collection)
    Dim i As Long
    For i = LBound(TypeChecks) To UBound(TypeChecks)
        Dim colName As String: colName = TypeChecks(i)(0)
        Dim wantType As String: wantType = TypeChecks(i)(1)
        Dim key As String: key = LCase(colName)
        If headerMap.Exists(key) Then
            Dim colNum As Long: colNum = headerMap(key)
            Dim val As Variant: val = sh.Cells(r, colNum).Value
            If Not IsEmpty(val) And Trim(CStr(val)) <> "" Then
                Select Case LCase(wantType)
                    Case "long"
                        If Not IsNumeric(val) Or CLng(val) <> val Then issues.Add "型不一致: '" & colName & "' は整数である必要があります"
                    Case "double"
                        If Not IsNumeric(val) Then issues.Add "型不一致: '" & colName & "' は数値である必要があります"
                    Case "date"
                        If Not IsDate(val) Then issues.Add "型不一致: '" & colName & "' は日付である必要があります"
                    Case "string"
                        ' OK
                    Case Else
                        ' 未知の型指定は無視
                End Select
            End If
        End If
    Next i
End Sub

Private Sub PerformRangeChecks(sh As Worksheet, headerMap As Object, r As Long, issues As Collection)
    Dim i As Long
    For i = LBound(RangeChecks) To UBound(RangeChecks)
        Dim colName As String: colName = RangeChecks(i)(0)
        Dim minVal As Variant: minVal = RangeChecks(i)(1)
        Dim maxVal As Variant: maxVal = RangeChecks(i)(2)
        Dim key As String: key = LCase(colName)
        If headerMap.Exists(key) Then
            Dim colNum As Long: colNum = headerMap(key)
            Dim val As Variant: val = sh.Cells(r, colNum).Value
            If IsNumeric(val) Then
                If val < minVal Or val > maxVal Then issues.Add "範囲外: '" & colName & "' は " & minVal & "〜" & maxVal & " の範囲にある必要があります"
            End If
        End If
    Next i
End Sub

Private Sub PerformAllowedValueChecks(sh As Worksheet, headerMap As Object, r As Long, issues As Collection)
    Dim i As Long
    For i = LBound(AllowedValues) To UBound(AllowedValues)
        Dim colName As String: colName = AllowedValues(i)(0)
        Dim allowed As Variant: allowed = AllowedValues(i)(1)
        Dim key As String: key = LCase(colName)
        If headerMap.Exists(key) Then
            Dim colNum As Long: colNum = headerMap(key)
            Dim val As Variant: val = CStr(sh.Cells(r, colNum).Value)
            If Trim(val) <> "" Then
                If Not IsInArray(val, allowed) Then issues.Add "不正な値: '" & colName & "' は許容値 (" & Join(allowed, ",") & ") のいずれかである必要があります"
            End If
        End If
    Next i
End Sub

Private Sub PerformUniqueKeyChecks(sh As Worksheet, headerMap As Object, r As Long, dictKeys As Object, issues As Collection)
    Dim i As Long
    If UBound(UniqueKeyColumns) < LBound(UniqueKeyColumns) Then Exit Sub
    Dim keyVal As String: keyVal = ""
    For i = LBound(UniqueKeyColumns) To UBound(UniqueKeyColumns)
        Dim colName As String: colName = UniqueKeyColumns(i)
        Dim key As String: key = LCase(colName)
        If headerMap.Exists(key) Then
            Dim colNum As Long: colNum = headerMap(key)
            keyVal = keyVal & "|" & CStr(sh.Cells(r, colNum).Value)
        Else
            ' カラム missing は上の必須チェックで拾う
        End If
    Next i
    If Trim(keyVal) <> "" Then
        If dictKeys.Exists(keyVal) Then
            issues.Add "重複キー: 一意キーが重複しています (" & keyVal & ")"
        Else
            dictKeys.Add keyVal, r
        End If
    End If
End Sub

Private Sub PerformCustomChecks(sh As Worksheet, headerMap As Object, r As Long, issues As Collection)
    ' ここに業務固有の検査を追加できます。
    ' 例: Date が未来日になっていないかをチェック
    Dim key As String: key = LCase("Date")
    If headerMap.Exists(key) Then
        Dim c As Long: c = headerMap(key)
        Dim v As Variant: v = sh.Cells(r, c).Value
        If IsDate(v) Then
            If CDate(v) > Date Then issues.Add "日付エラー: 'Date' が未来日になっています"
        End If
    End If

    ' 例: Amount がマイナスになっていないか
    key = LCase("Amount")
    If headerMap.Exists(key) Then
        c = headerMap(key)
        v = sh.Cells(r, c).Value
        If IsNumeric(v) Then
            If CDbl(v) < 0 Then issues.Add "金額エラー: 'Amount' が負の値です"
        End If
    End If
End Sub

' --------------------
' === ユーティリティ ===
' --------------------
Private Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If CStr(arr(i)) = CStr(val) Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False
End Function

' =====================================================
' End of module
' =====================================================

' --------------------
' 使い方メモ（モジュール内に追記）
' --------------------
' ・カラム名が異なる場合は InitConfig の RequiredColumns / TypeChecks / RangeChecks / AllowedValues を編集してください。
' ・チェックの追加は PerformCustomChecks に書き足してください。
' ・大量行を高速に処理したい場合は、Cells を直接参照するのではなく配列に読み込んで処理し、最後に書き戻す方法に変更すると速くなります。
' ・このツールはログ出力をシンプルにしています。必要ならレポートに "Sheet" や対象セルの値などを追加してください。
VB
VBA
スポンサーリンク
シェアする
@lifehackerをフォローする
スポンサーリンク
@lifehacker
スポンサーリンク
タイトルとURLをコピーしました