DBProcTest.bas

Const SETTINGS_SHEET_NAME = "実行"
Const CONNECT_STRING_ADDRESS = "C5"
Const CALL_ADDRESS = "C8"

Const INPUT_SHEET_PREFIX = "入力 "
Const CHECK_SHEET_PREFIX = "出力 "
Const NULL_MARK = "$NULL"
Const EMPTY_MARK = "$EMPTY"
Const ANY_MARK = "$ANY"

Const RESULT_SHEET_PREFIX = "結果 "
Const RESULT_TEXT_MATCH = "一致"
Const RESULT_TEXT_NOT_FOUND = "未検出"
Const RESULT_TEXT_WRONG = "誤検出"
Const RESULT_COLOR_NOT_FOUND = 8323327  ' RGB(255, 0, 127)
Const RESULT_COLOR_WRONG = 32767  ' RGB(255, 127, 0)
Const RESULT_COLOR_COMPLEMENTED = 12632256  ' RGB(192, 192, 192)

Const REPORT_SHEET_NAME = "レポート"
Const REPORT_TABLE_ROW_OFFSET = 5
Const REPORT_COLOR_PASS = 48896  ' RGB(0, 191, 0)
Const REPORT_COLOR_FAIL = 4210848  ' RGB(160, 64, 64)
Const REPORT_COL_PASS = 3
Const REPORT_COL_MATCH = 4
Const REPORT_COL_NOT_FOUNT = 5
Const REPORT_COL_WRONG = 6

Private Function StartsWith(text As String, prefix As String) As Boolean
    StartsWith = (Left(text, Len(prefix)) = prefix)
End Function

Private Function ContainsWorksheet(book As Workbook, sheetName As String)
    Dim ws As Worksheet
    For Each ws In book.Worksheets
        If ws.Name = sheetName Then
            ContainsWorksheet = True
            Exit Function
        End If
    Next
    ContainsWorksheet = False
End Function

Private Sub CleanResultBook(resultBook As Workbook)
    Application.DisplayAlerts = False
    Dim ws As Worksheet
    For Each ws In resultBook.Worksheets
        If StartsWith(ws.Name, RESULT_SHEET_PREFIX) Then
            ws.Delete
        End If
    Next
    If ContainsWorksheet(resultBook, REPORT_SHEET_NAME) Then
        Dim reportSheet As Worksheet, rowIndex As Integer
        Set reportSheet = resultBook.Worksheets(REPORT_SHEET_NAME)
        rowIndex = REPORT_TABLE_ROW_OFFSET
        Do While reportSheet.Cells(rowIndex + 1, 2) <> ""
            rowIndex = rowIndex + 1
        Loop
        With reportSheet.Range("B" & REPORT_TABLE_ROW_OFFSET, "F" & rowIndex)
            .Value = ""
            .Font.Bold = False
            .Font.Color = 0
            .Interior.Color = xlNone
        End With
    End If
    Application.DisplayAlerts = True
End Sub

Private Function GetMaxColumnIndex(ws As Worksheet)
    Dim colIndex As Integer
    colIndex = 1
    Do While ws.Cells(1, colIndex + 1) <> ""
        colIndex = colIndex + 1
    Loop
    GetMaxColumnIndex = colIndex
End Function

Private Function IsRowEmpty(ws As Worksheet, rowIndex As Integer, maxColIndex As Integer)
    Dim colIndex As Integer
    For colIndex = 1 To maxColIndex
        If ws.Cells(rowIndex, colIndex) <> "" Then
            IsRowEmpty = False
            Exit Function
        End If
    Next
    IsRowEmpty = True
End Function

Private Function GetMaxRowIndex(ws As Worksheet)
    Dim maxColIndex As Integer
    maxColIndex = GetMaxColumnIndex(ws)

    Dim rowIndex As Integer, colIndex As Integer
    rowIndex = 2
    Do Until IsRowEmpty(ws, rowIndex + 1, maxColIndex)
        rowIndex = rowIndex + 1
    Loop
    GetMaxRowIndex = rowIndex
End Function

Private Function MakeInsertSQL(tbName As String, ws As Worksheet)
    Dim colNamesStr As String, paramsStr As String
    Dim colIndex As Integer
    colNamesStr = ""
    paramsStr = ""
    For colIndex = 1 To GetMaxColumnIndex(ws)
        If colIndex > 1 Then
            colNamesStr = colNamesStr & ","
            paramsStr = paramsStr & ","
        End If
        colNamesStr = colNamesStr & ws.Cells(1, colIndex)
        paramsStr = paramsStr & "?"
    Next
    MakeInsertSQL = "INSERT INTO " & tbName & "(" & colNamesStr & ") VALUES(" & paramsStr & ")"
End Function

Private Sub SetUpTable(ws As Worksheet, cn As Object)
    Dim tbName As String
    tbName = Mid(ws.Name, Len(INPUT_SHEET_PREFIX) + 1)

    cn.Execute "DELETE FROM " & tbName
    
    Dim cmd As Object
    Set cmd = CreateObject("ADODB.Command")
    cmd.ActiveConnection = cn
    cmd.CommandText = MakeInsertSQL(tbName, ws)
    
    Dim maxColIndex As Integer, rowIndex As Integer
    maxColIndex = GetMaxColumnIndex(ws)
    For rowIndex = 2 To GetMaxRowIndex(ws)
        Dim colIndex As Integer
        For colIndex = 1 To maxColIndex
            Dim colValue As String
            colValue = ws.Cells(rowIndex, colIndex)
            
            If colValue = "" Or colValue = NULL_MARK Then
                cmd.Parameters(colIndex - 1) = Null
            ElseIf UCase(colValue) = EMPTY_MARK Then
                cmd.Parameters(colIndex - 1) = ""
            Else
                cmd.Parameters(colIndex - 1) = colValue
            End If
        Next
        
        cmd.Execute
    Next
End Sub

Private Sub CallProcedure(sql As String, cn As Object)
    cn.Execute sql
End Sub

Private Function MakeSelectSQL(tbName As String, ws As Worksheet)
    Dim colNamesStr As String
    Dim colIndex As Integer
    colNamesStr = ""
    For colIndex = 1 To GetMaxColumnIndex(ws)
        If colIndex > 1 Then
            colNamesStr = colNamesStr & ","
        End If
        colNamesStr = colNamesStr & ws.Cells(1, colIndex)
    Next
    MakeSelectSQL = "SELECT " & colNamesStr & " FROM " & tbName
End Function

Private Function MatchRow(expectedSheet As Worksheet, rowIndex As Integer, maxColIndexInEx As Integer, rs As Object) As Boolean
    For colIndex = 1 To maxColIndexInEx
        Dim exValue As String
        exValue = expectedSheet.Cells(rowIndex, colIndex)
        If exValue = ANY_MARK Then
            ' pass
        ElseIf exValue = "" Or exValue = NULL_MARK Then
            If Not IsNull(rs.Fields(colIndex - 1)) Then
                MatchRow = False
                Exit Function
            End If
        ElseIf exValue = EMPTY_MARK Then
            If rs.Fields(colIndex - 1) <> "" Then
                MatchRow = False
                Exit Function
            End If
        Else
            If rs.Fields(colIndex - 1) <> exValue Then
                MatchRow = False
                Exit Function
            End If
        End If
    Next
    MatchRow = True
End Function

Private Function ScanRow(expectedSheet As Worksheet, maxRowIndexInEx As Integer, maxColIndexInEx As Integer, resultSheet As Worksheet, rs As Object) As Integer
    Dim rowIndex As Integer
    For rowIndex = 2 To maxRowIndexInEx
        If resultSheet.Cells(rowIndex, 1) = RESULT_TEXT_NOT_FOUND Then
            If MatchRow(expectedSheet, rowIndex, maxColIndexInEx, rs) Then
                ScanRow = rowIndex
                Exit Function
            End If
        End If
    Next
    ScanRow = 0
End Function

Private Sub CheckTable(expectedSheet As Worksheet, resultBook As Workbook, cn As Object)
    Dim rowIndex As Integer, colIndex As Integer
    
    Dim tbName As String
    tbName = Mid(expectedSheet.Name, Len(INPUT_SHEET_PREFIX) + 1)
    
    Dim maxColIndexInEx As Integer, maxRowIndexInEx As Integer
    Dim wholeInEx As Range
    maxColIndexInEx = GetMaxColumnIndex(expectedSheet)
    maxRowIndexInEx = GetMaxRowIndex(expectedSheet)
    Set wholeInEx = expectedSheet.Range("A1", expectedSheet.Cells(maxRowIndexInEx, maxColIndexInEx))
    
    ' 結果シートの作成
    Dim resultSheet As Worksheet
    If resultBook.Sheets.Count = 0 Then
        Set resultSheet = resultBook.Worksheets.Add
    ElseIf ContainsWorksheet(resultBook, REPORT_SHEET_NAME) Then
        Set resultSheet = resultBook.Worksheets.Add(resultBook.Worksheets(REPORT_SHEET_NAME))
    Else
        Set resultSheet = resultBook.Worksheets.Add(After:=resultBook.Sheets(resultBook.Sheets.Count))
    End If
    resultSheet.Name = RESULT_SHEET_PREFIX & tbName
    wholeInEx.Copy resultSheet.Range("B1")
    resultSheet.Range("A1") = "結果"
    If maxRowIndexInEx >= 2 Then
        resultSheet.Range("A2:A" & maxRowIndexInEx) = RESULT_TEXT_NOT_FOUND
    End If
    
    ' SELECT 実行
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open MakeSelectSQL(tbName, expectedSheet), cn
    
    Dim maxRowIndexInRs As Integer
    maxRowIndexInRs = maxRowIndexInEx
    
    Do Until rs.EOF
        Dim matchRowIndex As Integer
        matchRowIndex = ScanRow(expectedSheet, maxRowIndexInEx, maxColIndexInEx, resultSheet, rs)
        
        If matchRowIndex > 0 Then
            resultSheet.Cells(matchRowIndex, 1) = RESULT_TEXT_MATCH
            For colIndex = 1 To maxColIndexInEx
                With resultSheet.Cells(matchRowIndex, colIndex + 1)
                    If .Value = ANY_MARK Then
                        Dim got As Variant
                        got = rs.Fields(colIndex - 1)
                        If IsNull(got) Then
                            .Value = NULL_MARK
                        ElseIf got = "" Then
                            .Value = EMPTY_MARK
                        Else
                            .Value = got
                        End If
                        .Font.Color = RESULT_COLOR_COMPLEMENTED
                    End If
                End With
            Next
        Else
            maxRowIndexInRs = maxRowIndexInRs + 1
            For colIndex = 1 To maxColIndexInEx
                resultSheet.Cells(maxRowIndexInRs, colIndex + 1) = rs.Fields(colIndex - 1)
            Next
            resultSheet.Cells(maxRowIndexInRs, 1) = RESULT_TEXT_WRONG
        End If
        
        rs.MoveNext
    Loop
    
    ' 表にする
    Dim wholeInRs As Range
    Set wholeInRs = resultSheet.Range("A1", resultSheet.Cells(maxRowIndexInRs, maxColIndexInEx + 1))
    resultSheet.ListObjects.Add SourceType:=xlSrcRange, Source:=wholeInRs, xllistobjecthasheaders:=xlYes
    
    ' フォント設定
    For rowIndex = 2 To maxRowIndexInRs
        Dim rsType As String
        rsType = resultSheet.Cells(rowIndex, 1)
        With resultSheet.Cells(rowIndex, 1)
            .Font.Bold = (rsType <> RESULT_TEXT_MATCH)
            .Interior.Color = _
                IIf(rsType = RESULT_TEXT_NOT_FOUND, RESULT_COLOR_NOT_FOUND, _
                IIf(rsType = RESULT_TEXT_WRONG, RESULT_COLOR_WRONG, _
                .Interior.Color))
            .Font.Color = IIf(rsType = RESULT_TEXT_MATCH, 0, RGB(255, 255, 255))
        End With
        With resultSheet.Range(resultSheet.Cells(rowIndex, 2), resultSheet.Cells(rowIndex, maxColIndexInEx + 1))
            .Font.Bold = (rsType <> RESULT_TEXT_MATCH)
            .Font.Color = _
                IIf(rsType = RESULT_TEXT_NOT_FOUND, RESULT_COLOR_NOT_FOUND, _
                IIf(rsType = RESULT_TEXT_WRONG, RESULT_COLOR_WRONG, _
                .Font.Color))
        End With
    Next
    
    rs.Close
End Sub

Private Sub CreateReport(resultBook As Workbook)
    Dim row As Range
    
    Dim reportSheet As Worksheet
    If ContainsWorksheet(resultBook, REPORT_SHEET_NAME) Then
        Set reportSheet = resultBook.Worksheets(REPORT_SHEET_NAME)
    Else
        Set reportSheet = resultBook.Worksheets.Add(After:=resultBook.Sheets(resultBook.Sheets.Count))
        reportSheet.Name = REPORT_SHEET_NAME
    End If
    
    reportSheet.Cells(3, 2) = Now
    
    Set row = reportSheet.Cells(REPORT_TABLE_ROW_OFFSET, 1)
    row.Cells(1, 2) = "テーブル"
    row.Cells(1, 3) = "合否"
    row.Cells(1, 4) = RESULT_TEXT_MATCH
    row.Cells(1, 5) = RESULT_TEXT_NOT_FOUND
    row.Cells(1, 6) = RESULT_TEXT_WRONG
    
    Dim ws As Worksheet, resultIndex As Integer
    resultIndex = 1
    For Each ws In resultBook.Worksheets
        If StartsWith(ws.Name, RESULT_SHEET_PREFIX) Then
            Set row = reportSheet.Cells(resultIndex + REPORT_TABLE_ROW_OFFSET, 2)
            With row(1, 1)
                .Value = Mid(ws.Name, Len(RESULT_SHEET_PREFIX) + 1)
                .Hyperlinks.Add anchor:=.Cells(1, 1), Address:="", SubAddress:="'" & ws.Name & "'!A1"
            End With
            With row(1, 3)
                .Value = WorksheetFunction.CountIf(ws.Range("A:A"), RESULT_TEXT_MATCH)
            End With
            With row(1, 4)
                .Value = WorksheetFunction.CountIf(ws.Range("A:A"), RESULT_TEXT_NOT_FOUND)
                If .Value > 0 Then
                    .Font.Bold = True
                    .Font.Color = RESULT_COLOR_NOT_FOUND
                End If
            End With
            With row(1, 5)
                .Value = WorksheetFunction.CountIf(ws.Range("A:A"), RESULT_TEXT_WRONG)
                If .Value > 0 Then
                    .Font.Bold = True
                    .Font.Color = RESULT_COLOR_WRONG
                End If
            End With
            With row(1, 2)
                If row(1, 4) = 0 And row(1, 5) = 0 Then
                    .Value = "PASS"
                    .Font.Bold = True
                    .Font.Color = RGB(255, 255, 255)
                    .Interior.Color = REPORT_COLOR_PASS
                Else
                    .Value = "FAIL"
                    .Font.Bold = True
                    .Font.Color = RGB(255, 255, 255)
                    .Interior.Color = REPORT_COLOR_FAIL
                End If
            End With
            
            resultIndex = resultIndex + 1
        End If
    Next
    
    reportSheet.Activate
End Sub

Public Sub Run()
    Dim settingsSheet As Worksheet
    Set settingsSheet = ThisWorkbook.Worksheets(SETTINGS_SHEET_NAME)
    
    CleanResultBook ThisWorkbook

    Dim cn As Object
    Set cn = CreateObject("ADODB.Connection")
    cn.Open settingsSheet.Range(CONNECT_STRING_ADDRESS)
    
    cn.Execute "BEGIN TRANSACTION"
    
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If StartsWith(ws.Name, INPUT_SHEET_PREFIX) Then
            SetUpTable ws, cn
        End If
    Next
    
    CallProcedure settingsSheet.Range(CALL_ADDRESS), cn
    
    For Each ws In ThisWorkbook.Worksheets
        If StartsWith(ws.Name, CHECK_SHEET_PREFIX) Then
            CheckTable ws, ThisWorkbook, cn
        End If
    Next
    
    cn.Execute "ROLLBACK"
    
    cn.Close
    
    CreateReport ThisWorkbook
End Sub