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

Question

初めまして、マロン36と申します。

複数のEXCELファイルに分かれて管理されている情報をACCESSに取り込み一括管理をしようとしています。

Workbookからデータを読み込んだ後、次のworkbookを読み込むためにQuitをしているのですが、データは参照しかしておらず更新していなにもかかわらずQuit時に必ず「データを保存しますか？ Yes/No」のメッセージが表示され、仕方がないので毎回Noを選択し先に進めています。

多数のEXCELファイルを読み込むため、「データを保存しますか？ Yes/No」の操作が非常に煩わしく、なんとかメッセージ出力を抑止したいのですが、色々な参考資料を見てもメッセージ抑止の方法がわかりません。

EXCELはACCESSから参照するのみで、更新することはありません。

どなたかEXCEL Workbookをquitした後に表示される不要なメッセージを抑止する方法をご教示いただけないでしょうか？

ACCESS、EXCELとも2010を使用していますが、EXCELファイルは他ユーザーとの互換性のために、.xls形式を使用しています。

よろしくお願いいたします。

Answer 1

Workbooksに対して、Close(False)を発行して廻ってからQuitすれば良いです。

あるいは、参照のみなら、Workbookを開く時にReadOnly属性をつける手もあります。

---

jzkey

Answer 2

jokeyさん、ありがとうございます。

書籍だとなかなか情報が見つからないので大変助かります。

workbookを開くとき、今は

Set Workbook1 = CreateObject("Excel Application")

Workbook1.Workbooks.Open ファイル名

としてworkbookを開いているのですが、ReadOnlyで開くためには、どのようなオプションをつければ良いのでしょうか？

なかなか情報が見つからず、ご教示いただけると大変助かります。

よろしくお願いします。

Answer 3

メモのため記録を残させてください。
※Office製品はマロン３６様より下位バージョンです。

'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

Answer 4

msuser_forumさん、うまくいきました。涙が出るほど嬉しい。本当に本当にありがとうございました。