'***************************************************************************************************
' MDB(ACCDB)初期データインポートツール
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
' ・Windows Script Host Object Model
' ・Microsoft Active Data Objects 2.x Library
'***************************************************************************************************
' 変更日付 Rev 変更履歴内容---------------------------------------------------------------------->
' 16/12/20(1.0.0)新規作成
' 17/01/07(1.0.0)一部修正+コメントの整備
' 19/11/24(1.1.0)MDB/ACCDB兼用版として再作成
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle = "MDB(ACCDB)データインポート"
Private Const g_cnsSH1 = "原紙"
Private Const g_cnsFilter = "MDB(ACCDB)ファイル (*.mdb;*.accdb),*.mdb;*.accdb"
Private Const g_cnsADO_Connect1 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="""
'***************************************************************************************************
'* 処理名 :MDBデータインポート
'* 機能 :MDB(ACCDB)へ初期データインポートを行なう
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月20日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub MDBデータインポート()
'-----------------------------------------------------------------------------------------------
Dim objWsh As WshShell ' WshShell
Dim dbCon As ADODB.Connection ' ADODB.Connection
Dim dbCmd As ADODB.Command ' ADODB.Command
Dim objSh As Worksheet ' Excel.Worksheet
Dim vntFilename As Variant ' ファイル名(受取)
Dim strFilename As String ' ファイル名
Dim strCurrentPathSV As String ' カレントフォルダ(退避)
'-----------------------------------------------------------------------------------------------
' MDB(ACCDB)ファイル名の受け取り
Set objWsh = New WshShell ' WshShell
' 一旦、カレントフォルダを退避
strCurrentPathSV = objWsh.CurrentDirectory
' 本ブックのフォルダをカレントフォルダに設定
objWsh.CurrentDirectory = ThisWorkbook.Path
' 「開く」ダイアログでファイル名の受け取り
vntFilename = Application.GetOpenFilename(g_cnsFilter, , _
"初期データを投入するMDB(ACCDB)ファイルを指定して下さい。")
' カレントフォルダの復旧
objWsh.CurrentDirectory = strCurrentPathSV
Set objWsh = Nothing
' キャンセル確認
If VarType(vntFilename) = vbBoolean Then Exit Sub
strFilename = vntFilename
'-----------------------------------------------------------------------------------------------
' MDBに接続
If Not FP_ConnectMDB(dbCon, strFilename) Then Exit Sub
' コマンドを生成
Set dbCmd = New ADODB.Command
dbCmd.ActiveConnection = dbCon
'-----------------------------------------------------------------------------------------------
' 本ブックのワークシートを巡回
For Each objSh In ThisWorkbook.Worksheets
' 「原紙」シートは除外
If objSh.Name <> g_cnsSH1 Then
' ワークシート単位処理
If Not FP_WorksheetProc(dbCon, dbCmd, objSh) Then Exit For
End If
Next objSh
' MDBを切断
dbCon.Close
Set dbCmd = Nothing
Set dbCon = Nothing
End Sub
'***************************************************************************************************
'* 処理名 :FP_WorksheetProc
'* 機能 :ワークシート単位処理
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数 :Arg1 = ADODB.Connection(Object)
'* Arg2 = ADODB.Command(Object)
'* Arg3 = Excel.Worksheet(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月20日
'* 作成者 :井上 治
'* 更新日 :2017年01月07日
'* 更新者 :井上 治
'* 機能説明:1つのテーブルに対する初期データの投入
'* 注意事項:先頭でDELETE文を発行しているので以前のデータは全て削除されます
'***************************************************************************************************
Private Function FP_WorksheetProc(ByRef dbCon As ADODB.Connection, _
ByRef dbCmd As ADODB.Command, _
ByRef objSh As Worksheet) As Boolean
'-----------------------------------------------------------------------------------------------
Dim lngRow As Long ' 行INDEX
Dim lngCol As Long ' カラムINDEX
Dim lngEndRow As Long ' 行INDEX上限
Dim lngEndCol As Long ' カラムINDEX上限
Dim strSQL_Base As String ' SQL文共通部
Dim strSQL As String ' SQL文
Dim strMSG As String ' メッセージ
With objSh
'-------------------------------------------------------------------------------------------
' 最終行、最終列の取得
If .FilterMode Then .ShowAllData
lngEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lngEndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' データ無しは無視
If ((lngEndRow <= 2) Or (lngEndCol < 1)) Then
FP_WorksheetProc = True
Exit Function
End If
'-------------------------------------------------------------------------------------------
' Transaction開始
dbCon.BeginTrans
'-------------------------------------------------------------------------------------------
' DELETE文発行
strSQL = "DELETE FROM " & FP_EditFieldName(.Name) & ";"
dbCmd.CommandText = strSQL
dbCmd.Execute
'-------------------------------------------------------------------------------------------
' INSERT文共通部の編集(シート名をテーブルID、1行目の値をフィールドIDとして編集)
strSQL_Base = "INSERT INTO " & FP_EditFieldName(.Name) & _
" (" & FP_EditFieldName(.Cells(1, 1).Value)
lngCol = 2
' 全列を編集
Do While lngCol <= lngEndCol
' フィールド名の編集(共通関数の呼び出し)
strSQL_Base = strSQL_Base & "," & FP_EditFieldName(.Cells(1, lngCol).Value)
' 次の列へ
lngCol = lngCol + 1
Loop
strSQL_Base = strSQL_Base & ") VALUES ("
On Error GoTo FP_WorksheetProc_ERROR
' データの先頭は3行目
lngRow = 3
'-------------------------------------------------------------------------------------------
' 全行を巡回
Do While lngRow <= lngEndRow
' 先頭項目のフィールド値の編集(共通関数の呼び出し)
strSQL = strSQL_Base & FP_EditFieldValue(.Cells(lngRow, 1), .Cells(2, 1).Value)
lngCol = 2
' カラムを巡回
Do While lngCol <= lngEndCol
' フィールド値の編集(共通関数の呼び出し)
strSQL = strSQL & "," & _
FP_EditFieldValue(.Cells(lngRow, lngCol), .Cells(2, lngCol).Value)
' 次の列へ
lngCol = lngCol + 1
Loop
strSQL = strSQL & ");"
' コマンドを発行
dbCmd.CommandText = strSQL
dbCmd.Execute
' 次の行へ
lngRow = lngRow + 1
Loop
'-------------------------------------------------------------------------------------------
' コミット
dbCon.CommitTrans
FP_WorksheetProc = True
On Error GoTo 0
End With
Exit Function
'===================================================================================================
' 処理失敗対応
FP_WorksheetProc_ERROR:
strMSG = "MDBへの更新に失敗しました。" & vbCrLf & Err.Description & vbCrLf & strSQL
MsgBox strMSG, vbCritical, g_cnsTitle
' ロールバック
On Error Resume Next
dbCon.RollbackTrans
FP_WorksheetProc = False
On Error GoTo 0
End Function
'***************************************************************************************************
'* 処理名 :FP_ConnectMDB
'* 機能 :MDBへの接続
'---------------------------------------------------------------------------------------------------
'* 返り値 :処理成否(Boolean)
'* 引数 :Arg1 = ADODB.Connection(Object)
'* Arg2 = MDBファイル名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月20日
'* 作成者 :井上 治
'* 更新日 :2019年11月24日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_ConnectMDB(ByRef dbCon As ADODB.Connection, _
ByVal strFilename As String) As Boolean
'-----------------------------------------------------------------------------------------------
Dim strConnectString As String ' 接続文字列
Dim strMSG As String ' メッセージ
' 接続文字列の編集
strConnectString = g_cnsADO_Connect1 & strFilename & """;"
On Error Resume Next
Set dbCon = New ADODB.Connection
' 接続を確立する
dbCon.Open strConnectString
' 接続確認
If Err.Number <> 0 Then
strMSG = "MDBへの接続に失敗しました。" & vbCrLf & Err.Description
MsgBox strMSG, vbCritical, g_cnsTitle
FP_ConnectMDB = False
Else
FP_ConnectMDB = True
End If
On Error GoTo 0
End Function
'***************************************************************************************************
' ■■■ 共通サブ処理 ■■■
'***************************************************************************************************
'* 処理名 :FP_EditFieldName
'* 機能 :フィールド名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数 :Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月20日
'* 作成者 :井上 治
'* 更新日 :2016年12月20日
'* 更新者 :井上 治
'* 機能説明:Trim及び鍵カッコで囲う
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditFieldName(ByVal strField As String) As String
'-----------------------------------------------------------------------------------------------
FP_EditFieldName = "[" & Trim(strField) & "]"
End Function
'***************************************************************************************************
'* 処理名 :FP_EditFieldValue
'* 機能 :フィールド値の編集
'---------------------------------------------------------------------------------------------------
'* 返り値 :編集後文字列(String)
'* 引数 :Arg1 = 対象セル(Range)
'* Arg2 = 項目タイプ(Integer)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2016年12月20日
'* 作成者 :井上 治
'* 更新日 :2016年12月20日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_EditFieldValue(ByRef objR As Range, ByVal intType As Integer) As String
'-----------------------------------------------------------------------------------------------
Select Case intType
Case 0 ' 文字列
FP_EditFieldValue = "'" & Trim(objR.Value) & "'"
Case 1 ' 整数
FP_EditFieldValue = "'" & CStr(CLng(objR.Value)) & "'"
Case 2 ' 実数
FP_EditFieldValue = "'" & CStr(CCur(objR.Value)) & "'"
Case 3 ' BOOL
FP_EditFieldValue = "'" & CStr(objR.Value = True) & "'"
Case 4 ' 日付
If objR.Value <> "" Then
FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd") & "'"
Else
FP_EditFieldValue = "NULL"
End If
Case 5 ' 時刻
If objR.Value <> "" Then
FP_EditFieldValue = "'" & Format(objR.Value, "yyyy-MM-dd HH:mm:ss") & "'"
Else
FP_EditFieldValue = "NULL"
End If
Case Else ' 文章
FP_EditFieldValue = "'" & Replace(Trim(objR.Value), "'", "''") & "'"
End Select
End Function
'------------------------------------------<< End of Source >>--------------------------------------