トップ回答者
ACCESSでEXCELを参照しQuitした時のメッセージ抑止方法

質問
-
初めまして、マロン36と申します。
複数のEXCELファイルに分かれて管理されている情報をACCESSに取り込み一括管理をしようとしています。
Workbookからデータを読み込んだ後、次のworkbookを読み込むためにQuitをしているのですが、データは参照しかしておらず更新していなにもかかわらずQuit時に必ず「データを保存しますか? Yes/No」のメッセージが表示され、仕方がないので毎回Noを選択し先に進めています。
多数のEXCELファイルを読み込むため、「データを保存しますか? Yes/No」の操作が非常に煩わしく、なんとかメッセージ出力を抑止したいのですが、色々な参考資料を見てもメッセージ抑止の方法がわかりません。
EXCELはACCESSから参照するのみで、更新することはありません。
どなたかEXCEL Workbookをquitした後に表示される不要なメッセージを抑止する方法をご教示いただけないでしょうか?
ACCESS、EXCELとも2010を使用していますが、EXCELファイルは他ユーザーとの互換性のために、.xls形式を使用しています。
よろしくお願いいたします。
回答
-
メモのため記録を残させてください。
※Office製品はマロン36様より下位バージョンです。
'ADODBで実行したサンプル
Sub Test1()
Dim xlApp As Object 'Excelオブジェクト
Dim xlBook As Object 'ワークブックオブジェクト
Dim xlSheet As Object 'ワークシートオブジェクト
Dim sPath As String 'データベースのパス
Dim sFilePath As String 'ファイルのパス
Dim sSheetName As String 'シート名
Dim sSQL As String 'SQL文
Dim lRow As Long 'Excelの行位置
Dim i As Integer 'ループカウンタ
Dim j As Integer 'ループカウンタ
sPath = Application.CurrentProject.Path
On Error GoTo ErrInfo
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Dim cn As ADODB.Connection
Set cn = CurrentProject.Connection
Dim cmd As New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdText
cmd.CommandTimeout = 0
cn.BeginTrans
sSheetName = "Sheet1"
'このサンプルでは3個のエクセルを開いて指定のテーブルに格納しています
For i = 1 To 3
sFilePath = sPath & "\test" & CStr(i) & ".xls"
'-------------------------------------------------------------------------
'エクセルを読取り専用で開きたい
'[URL]
'http://www.accessclub.jp/bbs5/0030/vba9397.html
'-------------------------------------------------------------------------
Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath, ReadOnly:=True)
'Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath, ReadOnly:=False)
'Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath)
Set xlSheet = xlBook.worksheets(sSheetName)
sSQL = "delete from tbl" & CStr(i)
cmd.CommandText = sSQL
cmd.Execute
lRow = 1
Do Until xlSheet.cells(lRow, 1).Value = ""
sSQL = "insert into tbl" & CStr(i) & " values("
For j = 1 To 3
If j > 1 Then
sSQL = sSQL & ","
End If
sSQL = sSQL & "'" & xlSheet.cells(lRow, j).Value & "'"
Next
sSQL = sSQL & ")"
cmd.CommandText = sSQL
cmd.Execute
lRow = lRow + 1
Loop
xlBook.Close
'-------------------------------------------------------------------------
'Don't show Save Dialog box on application quit
'[URL]
'http://www.mrexcel.com/forum/excel-questions/162545-dont-show-save-dialog-box-application-quit.html
'xlBook.Close 0
'-------------------------------------------------------------------------
'-------------------------------------------------------------------------
'Excelでブックを閉じるときに表示される"変更を保存しますか?"
'というメッセージを非表示にする方法
'[URL]
'https://support.microsoft.com/ja-jp/kb/213428
'xlBook.Close savechanges:=False
'-------------------------------------------------------------------------
Next
cn.CommitTrans
ErrInfo:
If Err.Number <> 0 Then
dubug.Print Err.Description & "(" & Err.Number & ")"
cn.RollbackTrans
End If
cn.Close
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
'DoCmdで実行したサンプル
Sub Test2()
Dim sPath As String 'アプリのパス
Dim sFilePath As String 'ファイルのパス
Dim sSheetName As String 'シート名
Dim sSQL As String 'SQL文
Dim i As Integer 'ループカウンタ
sPath = Application.CurrentProject.Path
On Error GoTo ErrInfo
'このサンプルでは3個のエクセルを開いて指定のテーブルに格納しています
For i = 1 To 3
sFilePath = sPath & "\test" & CStr(i) & ".xls"
DoCmd.DeleteObject acTable, "tbl" & CStr(i)
'-------------------------------------------------------------------------
'DoCmd.TransferSpreadsheet メソッド (Access)
'[URL]
'https://msdn.microsoft.com/ja-jp/library/office/ff844793.aspx
'-------------------------------------------------------------------------
DoCmd.TransferSpreadsheet acImport, , "tbl" & CStr(i), sFilePath, False
Next
ErrInfo:
If Err.Number <> 0 Then
dubug.Print Err.Description & "(" & Err.Number & ")"
End If
End Sub
- 編集済み msuser_forum 2016年9月4日 20:44
- 回答としてマーク マロン36 2016年9月5日 21:21
すべての返信
-
メモのため記録を残させてください。
※Office製品はマロン36様より下位バージョンです。
'ADODBで実行したサンプル
Sub Test1()
Dim xlApp As Object 'Excelオブジェクト
Dim xlBook As Object 'ワークブックオブジェクト
Dim xlSheet As Object 'ワークシートオブジェクト
Dim sPath As String 'データベースのパス
Dim sFilePath As String 'ファイルのパス
Dim sSheetName As String 'シート名
Dim sSQL As String 'SQL文
Dim lRow As Long 'Excelの行位置
Dim i As Integer 'ループカウンタ
Dim j As Integer 'ループカウンタ
sPath = Application.CurrentProject.Path
On Error GoTo ErrInfo
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Dim cn As ADODB.Connection
Set cn = CurrentProject.Connection
Dim cmd As New ADODB.Command
cmd.ActiveConnection = cn
cmd.CommandType = adCmdText
cmd.CommandTimeout = 0
cn.BeginTrans
sSheetName = "Sheet1"
'このサンプルでは3個のエクセルを開いて指定のテーブルに格納しています
For i = 1 To 3
sFilePath = sPath & "\test" & CStr(i) & ".xls"
'-------------------------------------------------------------------------
'エクセルを読取り専用で開きたい
'[URL]
'http://www.accessclub.jp/bbs5/0030/vba9397.html
'-------------------------------------------------------------------------
Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath, ReadOnly:=True)
'Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath, ReadOnly:=False)
'Set xlBook = xlApp.workbooks.Open(FileName:=sFilePath)
Set xlSheet = xlBook.worksheets(sSheetName)
sSQL = "delete from tbl" & CStr(i)
cmd.CommandText = sSQL
cmd.Execute
lRow = 1
Do Until xlSheet.cells(lRow, 1).Value = ""
sSQL = "insert into tbl" & CStr(i) & " values("
For j = 1 To 3
If j > 1 Then
sSQL = sSQL & ","
End If
sSQL = sSQL & "'" & xlSheet.cells(lRow, j).Value & "'"
Next
sSQL = sSQL & ")"
cmd.CommandText = sSQL
cmd.Execute
lRow = lRow + 1
Loop
xlBook.Close
'-------------------------------------------------------------------------
'Don't show Save Dialog box on application quit
'[URL]
'http://www.mrexcel.com/forum/excel-questions/162545-dont-show-save-dialog-box-application-quit.html
'xlBook.Close 0
'-------------------------------------------------------------------------
'-------------------------------------------------------------------------
'Excelでブックを閉じるときに表示される"変更を保存しますか?"
'というメッセージを非表示にする方法
'[URL]
'https://support.microsoft.com/ja-jp/kb/213428
'xlBook.Close savechanges:=False
'-------------------------------------------------------------------------
Next
cn.CommitTrans
ErrInfo:
If Err.Number <> 0 Then
dubug.Print Err.Description & "(" & Err.Number & ")"
cn.RollbackTrans
End If
cn.Close
xlApp.Quit
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
'DoCmdで実行したサンプル
Sub Test2()
Dim sPath As String 'アプリのパス
Dim sFilePath As String 'ファイルのパス
Dim sSheetName As String 'シート名
Dim sSQL As String 'SQL文
Dim i As Integer 'ループカウンタ
sPath = Application.CurrentProject.Path
On Error GoTo ErrInfo
'このサンプルでは3個のエクセルを開いて指定のテーブルに格納しています
For i = 1 To 3
sFilePath = sPath & "\test" & CStr(i) & ".xls"
DoCmd.DeleteObject acTable, "tbl" & CStr(i)
'-------------------------------------------------------------------------
'DoCmd.TransferSpreadsheet メソッド (Access)
'[URL]
'https://msdn.microsoft.com/ja-jp/library/office/ff844793.aspx
'-------------------------------------------------------------------------
DoCmd.TransferSpreadsheet acImport, , "tbl" & CStr(i), sFilePath, False
Next
ErrInfo:
If Err.Number <> 0 Then
dubug.Print Err.Description & "(" & Err.Number & ")"
End If
End Sub
- 編集済み msuser_forum 2016年9月4日 20:44
- 回答としてマーク マロン36 2016年9月5日 21:21