ティーダ１

後日、記事を是正致します。

```vb
Option Explicit

'テーブル一覧
Const TL1                       As String = "サブシステム"
Const TL2                       As String = "画面"
Const TL3                       As String = "画面種別リスト"
Const TL4                       As String = "業務"
Const TL5                       As String = "業務管理テーブル用追加情報"
Const TL6                       As String = "業務使用帳票"
Const TL7                       As String = "業務実行可能権限"
Const TL8                       As String = "業務親子２"
Const TL9                       As String = "権限リスト"
Const TL10                      As String = "個別業務画面"
Const TL11                      As String = "個別業務付加情報"
Const TL12                      As String = "修正履歴"
Const TL13                      As String = "遷移先画面"
Const TL14                      As String = "帳票"
Const TL15                      As String = "帳票フォーム"
Const TL16                      As String = "帳票取出可能権限"
Const TL17                      As String = "帳票紐付け"
Const TL18                      As String = "流用元画面"


'定数
Const extensionAttribute        As String = "Microsoft Access Database"
Const extension                 As String = "mdb"
Const writeMessage              As String = "変更はありませんでした"
Const succesedMessage           As String = "正常に処理が完了しました"
Const errorMessage_ws           As String = "帳票出力仕様のワークシートが存在しません"
Const errorMessage_fd           As String = "ファイルダイアログがキャンセルされました"


Sub CreateDiffrent_Click()

    Dim fd                          As FileDialog
    Dim wb                          As Workbook
    '旧データベース
    Dim dbA                         As String
    Dim dbA_T1()                    As String
    Dim dbA_T2()                    As String
    Dim dbA_T3()                    As String
    Dim dbA_T4()                    As String
    Dim dbA_T5()                    As String
    Dim dbA_T6()                    As String
    Dim dbA_T7()                    As String
    Dim dbA_T8()                    As String
    Dim dbA_T9()                    As String
    Dim dbA_T10()                   As String
    Dim dbA_T11()                   As String
    Dim dbA_T12()                   As String
    Dim dbA_T13()                   As String
    Dim dbA_T14()                   As String
    Dim dbA_T15()                   As String
    Dim dbA_T16()                   As String
    Dim dbA_T17()                   As String
    Dim dbA_T18()                   As String
    '新データベース
    Dim dbB                         As String
    Dim dbB_T1()                    As String
    Dim dbB_T2()                    As String
    Dim dbB_T3()                    As String
    Dim dbB_T4()                    As String
    Dim dbB_T5()                    As String
    Dim dbB_T6()                    As String
    Dim dbB_T7()                    As String
    Dim dbB_T8()                    As String
    Dim dbB_T9()                    As String
    Dim dbB_T10()                   As String
    Dim dbB_T11()                   As String
    Dim dbB_T12()                   As String
    Dim dbB_T13()                   As String
    Dim dbB_T14()                   As String
    Dim dbB_T15()                   As String
    Dim dbB_T16()                   As String
    Dim dbB_T17()                   As String
    Dim dbB_T18()                   As String
    
    '差分保存用DB
    Dim dbC                         As String
    Dim dbC_T1()                    As String
    Dim dbC_T2()                    As String
    Dim dbC_T3()                    As String
    Dim dbC_T4()                    As String
    Dim dbC_T5()                    As String
    Dim dbC_T6()                    As String
    Dim dbC_T7()                    As String
    Dim dbC_T8()                    As String
    Dim dbC_T9()                    As String
    Dim dbC_T10()                   As String
    Dim dbC_T11()                   As String
    Dim dbC_T12()                   As String
    Dim dbC_T13()                   As String
    Dim dbC_T14()                   As String
    Dim dbC_T15()                   As String
    Dim dbC_T16()                   As String
    Dim dbC_T17()                   As String
    Dim dbC_T18()                   As String
    
    Dim relativePath                As String
    
    Dim i                           As Long
    Dim j                           As Long
    
    '相対パス
    relativePath = ActiveWorkbook.Path
    
    'ダイアログピッカーの生成とプロパティの設定
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    With fd
        .Filters.Clear
        .Filters.Add extensionAttribute, "*." + extension
        .AllowMultiSelect = False
    End With
    
    ' dbAのパス取得
    MsgBox "古いAccessデータを参照してください", vbInformation
    
    If Not fd.Show Then
        MsgBox errorMessage_fd, vbExclamation
        Exit Sub
    Else
        dbA = fd.SelectedItems(1)
    End If
    
    ' dbBのパス取得
    MsgBox "新しいAccessデータを参照してください", vbInformation
    
    If Not fd.Show Then
        MsgBox errorMessage_fd, vbExclamation
        Exit Sub
    Else
        dbB = fd.SelectedItems(1)
    End If
    
    'dbAに対してデータベースの操作を行う
    If (getAccessConnection(dbA, dbA_T1, dbA_T2, dbA_T3, dbA_T4, dbA_T5, dbA_T6, dbA_T7, dbA_T8, dbA_T9, dbA_T10, dbA_T11, dbA_T12, dbA_T13, dbA_T14, dbA_T15, dbA_T16, dbA_T17, dbA_T18)) <> True Then
        MsgBox "データベース操作エラーです 1", vbExclamation
        Exit Sub
    End If
    
    'dbBに対してデータベースの操作を行う
    If (getAccessConnection(dbB, dbB_T1, dbB_T2, dbB_T3, dbB_T4, dbB_T5, dbB_T6, dbB_T7, dbB_T8, dbB_T9, dbB_T10, dbB_T11, dbB_T12, dbB_T13, dbB_T14, dbB_T15, dbB_T16, dbB_T17, dbB_T18)) <> True Then
        MsgBox "データベース操作エラーです 2", vbExclamation
        Exit Sub
    End If
    
    '差分取得処理を開始する
    Set wb = Workbooks.Add
    
    ' how to use A古いの B新しいの
    
    ' 差異について抽出 この場合、Bが差分
    Call margeData(dbA_T12, dbB_T12, dbC_T12)
    Call margeData(dbA_T2, dbB_T2, dbC_T2)
    Call margeData(dbA_T3, dbB_T3, dbC_T3)
    Call margeData(dbA_T4, dbB_T4, dbC_T4)
    Call margeData(dbA_T5, dbB_T5, dbC_T5)
    Call margeData(dbA_T6, dbB_T6, dbC_T6)
    Call margeData(dbA_T7, dbB_T7, dbC_T7)
    Call margeData(dbA_T8, dbB_T8, dbC_T8)
    Call margeData(dbA_T9, dbB_T9, dbC_T9)
    Call margeData(dbA_T10, dbB_T10, dbC_T10)
    Call margeData(dbA_T11, dbB_T11, dbC_T11)
    Call margeData(dbA_T12, dbB_T12, dbC_T12)
    Call margeData(dbA_T13, dbB_T13, dbC_T13)
    Call margeData(dbA_T14, dbB_T14, dbC_T14)
    Call margeData(dbA_T15, dbB_T15, dbC_T15)
    Call margeData(dbA_T16, dbB_T16, dbC_T16)
    Call margeData(dbA_T17, dbB_T17, dbC_T17)
    Call margeData(dbA_T18, dbB_T18, dbC_T18)
    
    ' 結果を書き込む
    Call writeSheetArray2Index(wb, dbC_T1, TL1)
    Call writeSheetArray2Index(wb, dbC_T2, TL2)
    Call writeSheetArray2Index(wb, dbC_T3, TL3)
    Call writeSheetArray2Index(wb, dbC_T4, TL4)
    Call writeSheetArray2Index(wb, dbC_T5, TL5)
    Call writeSheetArray2Index(wb, dbC_T6, TL6)
    Call writeSheetArray2Index(wb, dbC_T7, TL7)
    Call writeSheetArray2Index(wb, dbC_T8, TL8)
    Call writeSheetArray2Index(wb, dbC_T9, TL9)
    Call writeSheetArray2Index(wb, dbC_T10, TL10)
    Call writeSheetArray2Index(wb, dbC_T11, TL11)
    Call writeSheetArray2Index(wb, dbC_T12, TL12)
    Call writeSheetArray2Index(wb, dbC_T13, TL13)
    Call writeSheetArray2Index(wb, dbC_T14, TL14)
    Call writeSheetArray2Index(wb, dbC_T15, TL15)
    Call writeSheetArray2Index(wb, dbC_T16, TL16)
    Call writeSheetArray2Index(wb, dbC_T17, TL17)
    Call writeSheetArray2Index(wb, dbC_T18, TL18)

    
    Debug.Print "OK"
    
    '差分を保存する。
    wb.SaveAs Filename:=relativePath & "\業務体系表差分_" & Format(Now(), "YYYYMMDDHHMMSS"), _
              FileFormat:=xlOpenXMLWorkbook
    wb.Close
    
End Sub

Function isEmptyArray(s() As String) As Boolean
    If (Not s) = -1 Then
        isEmptyArray = True
    Else
        isEmptyArray = (UBound(s) = 0 And s(0) = "")
    End If
End Function

Function isArrayEx(varArray As Variant) As Long
On Error GoTo ERROR_
    
    If IsArray(varArray) Then
        isArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        isArrayEx = -1
    End If
    
    Exit Function
    
ERROR_:
    If Err.Number = 9 Then
        isArrayEx = 0
    End If
End Function

'ADODBObjectをゲットする
Function getAccessConnection( _
        dbPath As String, _
        ByRef T1() As String, ByRef T2() As String, ByRef T3() As String, _
        ByRef T4() As String, ByRef T5() As String, ByRef T6() As String, _
        ByRef T7() As String, ByRef T8() As String, ByRef T9() As String, _
        ByRef T10() As String, ByRef T11() As String, ByRef T12() As String, _
        ByRef T13() As String, ByRef T14() As String, ByRef T15() As String, _
        ByRef T16() As String, ByRef T17() As String, ByRef T18() As String _
                            ) As Boolean
    'objects
    Dim con             As ADODB.Connection
    Dim rs              As ADODB.Recordset
    Dim i               As Long
    Dim j               As Long
    
    Dim message         As String
    
    Dim tmpFilCnt       As Long
    
    Dim tempArray       As Variant
    
    ' エクセルプロパティの初期化
    Set con = New ADODB.Connection
    Set rs = New ADODB.Recordset
    
    'db connection
    con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
    
    'transaciton
    On Error GoTo connectionERROR
    
    'Transaction Start
    con.BeginTrans
        'Query sets
        Call getTableData(T1, con, rs, "SELECT * FROM " & TL1 & ";")
        Call getTableData(T2, con, rs, "SELECT * FROM " & TL2 & ";")
        Call getTableData(T3, con, rs, "SELECT * FROM " & TL3 & ";")
        Call getTableData(T4, con, rs, "SELECT * FROM " & TL4 & ";")
        Call getTableData(T5, con, rs, "SELECT * FROM " & TL5 & ";")
        Call getTableData(T6, con, rs, "SELECT * FROM " & TL6 & ";")
        Call getTableData(T7, con, rs, "SELECT * FROM " & TL7 & ";")
        Call getTableData(T8, con, rs, "SELECT * FROM " & TL8 & ";")
        Call getTableData(T9, con, rs, "SELECT * FROM " & TL9 & ";")
        Call getTableData(T10, con, rs, "SELECT * FROM " & TL10 & ";")
        Call getTableData(T11, con, rs, "SELECT * FROM " & TL11 & ";")
        Call getTableData(T12, con, rs, "SELECT * FROM " & TL12 & ";")
        Call getTableData(T13, con, rs, "SELECT * FROM " & TL13 & ";")
        Call getTableData(T14, con, rs, "SELECT * FROM " & TL14 & ";")
        Call getTableData(T15, con, rs, "SELECT * FROM " & TL15 & ";")
        Call getTableData(T16, con, rs, "SELECT * FROM " & TL16 & ";")
        Call getTableData(T17, con, rs, "SELECT * FROM " & TL17 & ";")
        Call getTableData(T18, con, rs, "SELECT * FROM " & TL18 & ";")
    'Transaction End
    con.CommitTrans

    'Close processing
    con.Close
    Set con = Nothing
    Set rs = Nothing
    getAccessConnection = True
    Exit Function
connectionERROR:
    'Close processing rollback
    con.RollbackTrans
    con.Close
    Set con = Nothing
    Set rs = Nothing
    getAccessConnection = False
End Function


Sub getTableData(ByRef data() As String, ByRef con As ADODB.Connection, ByVal rs As ADODB.Recordset, query As String)
    Dim i               As Long
    Dim j               As Long
    Dim tempArray       As Variant
    
    Set rs = con.Execute(query)
    
    tempArray = rs.GetRows
    ReDim data(0 To UBound(tempArray, 2), 0 To UBound(tempArray, 1))
    
    '文字変換はCStrを使用する事
    For i = 0 To UBound(tempArray, 2)
        For j = 0 To UBound(tempArray, 1)
            If IsNull(tempArray(j, i)) = False Then
                data(i, j) = CStr(tempArray(j, i))
            Else
                data(i, j) = ""
            End If
        Next j
    Next i
    
    Set rs = Nothing
    
End Sub

Sub margeData(A() As String, B() As String, C() As String)
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim l           As Long
    
    Dim dsw         As Boolean
    Dim countCol    As Long
    Dim ckcnt       As Long
    
    Dim temp()      As String
    
    ' 作業配列の初期化
    ReDim temp(0 To UBound(B, 1), 0 To UBound(B, 2))
    countCol = 0
    
    If (isArrayEx(A) = 1 And isArrayEx(B) = 1) Then
        For i = 0 To UBound(B, 1)
            dsw = False
            'Aの要素がBにマッチしなければ何もしない
            If isArrayEx(B) = 1 Then
                For k = 0 To UBound(A, 1)
                    ckcnt = 0
                    For j = 0 To UBound(A, 2)
                        If B(i, j) = A(k, j) Then
                            ckcnt = ckcnt + 1
                        Else
                            Exit For
                        End If
                    Next j
                    
                    If ckcnt - 1 = UBound(B, 2) Then
                      dsw = True
                      Exit For
                    End If
                Next k
            End If
            
            If dsw = False Then
                If isArrayEx(B) = 1 And UBound(B) > 0 Then
                    For j = 0 To UBound(B, 2)
                        temp(countCol, j) = B(i, j)
                    Next j
                    
                    Erase C
                    ReDim C(0 To countCol, 0 To UBound(B, 2))
                    C = temp
                    
                    countCol = countCol + 1
                    
                End If
            End If
        Next i
        
    End If
    
End Sub


Sub writeSheetArray2Index(ByRef wb As Workbook, array2index() As String, TL As String)
    Dim row         As Long
    Dim col         As Long
    Dim i           As Long
    Dim j           As Long
    Dim sheet       As Worksheet
    'create sheet
    wb.Worksheets.Add
    Set sheet = wb.ActiveSheet
    sheet.Name = TL
    
    row = 1
     If isArrayEx(array2index) = 1 Then
        For i = 0 To UBound(array2index, 1)
            col = 1
            For j = 0 To UBound(array2index, 2)
                sheet.Cells(row, col).Value = array2index(i, j)
                col = col + 1
            Next j
        row = row + 1
        Next i
    End If
    
End Sub
```