●ACCESS→Excelのエクスポート（マクロ）で教えて下さい。

質問

ACCESS2000、WindowsXPです。

テーブルをExcelへエクスポートするマクロを作りましが、
下記で苦労しています。
(1)マクロ実行してから「エクスポートしますか？」「OK/キャンセルボタン」ウインドウを出したい。
(2)保存場所を一定の場所に指定したい。

数人で使用する為、該当ACCESSファイルが置いてあるネットワーク上の
フォルダ（\\Central-server\public）に指定してみましたが、ファイルを移動した際等に、
パスが変わってしまうので一定の場所に設定したいです。
→各々のPCの「デスクトップ」or「該当ACCESSといつも同じフォルダ」

今のところ、下記のように設定してます。

【作成したマクロ】
◆アクション1→ワークシート変換
・変換の種類：エクスポート
・ワークシートの種類：Microsoft Excel8-9
・テーブル名：ＢＥ
・ファイル名：
="C:\Documents and Settings\User\デスクトップ\ＢＥ_" & Format(Now(),"yymmdd_hhnnss") & ".xls"
もしくは、
="\\Central-server\public\ＢＥ_" & Format(Now(),"yymmdd_hhnnss") & ".xls"

◆アクション2→メッセージボックス
・「エクスポート完了しました。」→OKしか出ない。

どなたかご教授頂けないでしょうか。
宜しくお願いいたします。

回答No.1

p-applepie · ベストアンサー

コマンドボタンにのイベントにイベントプロシージャを入れて
VBAを記述するのではだめですか？

YYMMDD00_ファイル名.xls　と言うファイル名でデスクトップに
エクスポートします。
同日にエクスポートすれば01　02とカウントアップしていきます。

Private Sub Excel出力_Click()

On Error GoTo Err_Excel出力_Click

Dim newFile As Double 'Excelファイル名YYYYMMDD＋連番2桁(数値)
Dim strPath As String '作成するファイル名YYMMDD連番ファイル名(文字列)
Dim srchXls As String '作成するフルパス
newFile = Val(Format(Date, "yyyymmdd") & Format(0, "00")) 'newFileをYYYYMMDD00とする

Do
newFile = newFile + 1 'newFileの00部分に＋1
strPath = Mid(newFile, 3, 6) & "_" & Right(newFile, 2) & "_Excelファイル名.xls" 'YYMMDD_00_ファイル名+拡張子
srchXls = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & strPath 'デスクトップを取得してフルパスをセット

Loop Until strPath <> Dir(srchXls, vbNormal) 'Dir検索で　指定したファイル名があればループから抜ける

Select Case MsgBox(srchXls & "を作成しますか？", vbOKCancel) 'MsgBoxでファイル作成のOKCancel確認OKの場合ファイル作成
Case vbOK
DoCmd.TransferSpreadsheet acExport, , "エクスポートするクエリ名", srchXls, True 'OKの場合指定したフルパスでエクスポート
MsgBox (srchXls & Chr(13) & Chr(10) & "が作成されました") '完了メッセージ　OKしか表示されない
Shell "Excel.exe " & Chr(&H22) & srchXls & Chr(&H22), vbNormalFocus 'Shellで作成したExcelを起動

Case Else
Exit Sub 'Cancelの場合Subプロシージャから抜ける
End Select

Exit_Excel出力_Click:
Exit Sub

Err_Excel出力_Click:
MsgBox Err.Number & Err.Description
Resume Exit_Excel出力_Click

End Sub

お礼

度々すみません。
式がやっと読めてきました（汗）
下記で成功しました。
ありがとうございました！！！

---
Private Sub Excel出力_Click()

On Error GoTo Err_Excel出力_Click

Dim newFile As Double
Dim strPath As String
Dim srchXls As String
newFile = Val(Format(Date, "yyyymmdd") & Format(0, "00"))

Do
newFile = newFile + 1
strPath = "ＢＥ_" & Mid(newFile, 3, 6) & "_" & Right(newFile, 2) & ".xls"
srchXls = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & strPath

Loop Until strPath <> Dir(srchXls, vbNormal)

Select Case MsgBox(srchXls & "を作成しますか？", vbOKCancel)
Case vbOK
DoCmd.TransferSpreadsheet acExport, , "ＢＥ", srchXls, True
MsgBox (srchXls & Chr(13) & Chr(10) & "を作成しました。")

Case Else
Exit Sub
End Select

Exit_Excel出力_Click:
Exit Sub

Err_Excel出力_Click:
MsgBox Err.Number & Err.Description
Resume Exit_Excel出力_Click

End Sub

補足

すすすすすみません。
とりあえず自分流に編集してみたんですが、コンパイルエラーです。
ボタンの名前と課題を"Excel出力"にし、クリック時のイベントプロシージャに下記をコピーしました。
1行目が黄色く、End Subが青く反転してます。
添削できますでしょうか。
宜しくお願いいたします。

---
Private Sub Excel出力_Click()

On Error GoTo Err_Excel出力_Click

Dim newFile As Double
Dim strPath As String
Dim srchXls As String
newFile = Val("ＢＥ_" & Format(Now(), "yymmdd_hhnnss") & ".xls")

Do
srchXls = CreateObject("WScript.Shell").SpecialFolders("desktop") & "\" & strPath

Select Case MsgBox("ファイルを作成しますか？", vbOKCancel)
Case vbOK
DoCmd.TransferSpreadsheet acExport, , "ＢＥ", srchXls, True
MsgBox ("デスクトップにファイルが作成されました")

Case Else
Exit Sub
End Select

Exit_Excel出力_Click:
Exit Sub

Err_Excel出力_Click:
MsgBox Err.Number & Err.Description
Resume Exit_Excel出力_Click

End Sub