Access VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

8304 / 9994

←次へ　｜　前へ→


	【4867】Re:既存のExcelファイルにエクスポートす...

小僧 - 05/4/11(月) 10:27 -


	引用なし

	パスワード

土曜日にちょっと覗いた時に、シート名を日付で…という
投稿があったように思われたのですが、削除されてしましましたね…。

コードを考えたのでアップしておきます。

Sub xlsOut()
Dim FSO As Object
Dim xlsApp As New Excel.Application
Dim xlsWkb As New Excel.Workbook
Dim MyTBL As String
Dim MyFile As Variant
Dim MyDate As String
Dim MySheet As Variant
Dim Cnt As Long
　　
'出力するテーブル、出力先ファイルの指定
　　MyDate = Format(Now(), "m月dd日")
　　MyTBL = "tempTBL"
　　MyFile = "c:\temp.xls"

'存在チェック
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　　　If Not (FSO.FileExists(MyFile)) Then
　　　　　　DoCmd.TransferSpreadsheet acExport, _
　　　　　　acSpreadsheetTypeExcel9, MyTBL, MyFile, True
　　　　　　
'エクセルシートの名前を変更
　　　　　　Set xlsWkb = xlsApp.Workbooks.Open(MyFile)
　　　　　　xlsWkb.Sheets(MyTBL).Name = MyDate
　　　　　　xlsWkb.Save
　　　　　　xlsWkb.Close: Set xlsWkb = Nothing
　　　　　　xlsApp.Quit: Set xlsApp = Nothing
　　　　Else

'同日のシートが見つかった場合は削除
　　　　　　Set xlsWkb = xlsApp.Workbooks.Open(MyFile)
　　　　　　For Each MySheet In xlsWkb.Sheets
　　　　　　　　If MySheet.Name = MyDate Then
　　　　　　　　　　xlsApp.DisplayAlerts = False
　　　　　　　　　　xlsWkb.Sheets(MyDate).Delete
　　　　　　　　　　xlsApp.DisplayAlerts = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next

'出力先ファイルにシートを追加
　　　　　　Cnt = xlsWkb.Sheets.Count
　　　　　　xlsWkb.Sheets.Add after:=xlsApp.Worksheets(Cnt)
　　　　　　xlsWkb.ActiveSheet.Name = MyDate
　　　　　　xlsWkb.Save
　　　　　　xlsWkb.Close: Set xlsWkb = Nothing
　　　　　　xlsApp.Quit: Set xlsApp = Nothing
　　　　DoCmd.TransferSpreadsheet acExport, _
　　　　acSpreadsheetTypeExcel9, MyTBL, MyFile, True, MyDate & "!"
　　　　End If
End Sub

１日に複数回出力した場合は、最新のシートのみが存在します。

2,253 hits

▼

【4842】既存のExcelファイルにエクスポートするには にしもり 05/4/7(木) 16:34