後日、記事を是正致します。
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