Access VBA質問箱 IV

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

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


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

8253 / 9994

←次へ　｜　前へ→


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

小僧 - 05/4/18(月) 9:56 -


	引用なし

	パスワード

▼clike さん：
おはようございます。

>「実行エラー'1004':
>ブックのシートをすべて削除または非表示にすることはできません」
>というエラー表示がでています。

シートが１枚しかない時は削除できない、という事を
考慮しておりませんでした。
当日のシートがあった時は削除でなく、クリア処理で対応してみました。

Sub xlsOut()
Dim FSO As Object
Dim RS As DAO.Recordset
Dim xlsApp As New Excel.Application
Dim xlsWkb As New Excel.Workbook
Dim xlsSht As New Excel.Worksheet
Dim MyTBL As String
Dim MyFile As Variant
Dim MyDate As String
Dim MySheet As Variant
Dim Cnt As Long
Dim FLG As Boolean

'出力するテーブル、出力先ファイルの指定
　　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 RS = CurrentDb.OpenRecordset(MyTBL, dbOpenDynaset)
　　　　　　Set xlsWkb = xlsApp.Workbooks.Open(MyFile)

'同日のシートの検索
　　　　　　FLG = False
　　　　　　For Each MySheet In xlsWkb.Sheets
　　　　　　　　If MySheet.Name = MyDate Then
　　　　　　　　　　FLG = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next

'出力先ファイルのシートを選択
　　　　　　If FLG Then
　　　　　　　　xlsWkb.Sheets(MyDate).Cells.ClearContents
　　　　　　Else
　　　　　　　　Cnt = xlsWkb.Sheets.Count
　　　　　　　　xlsWkb.Sheets.Add after:=xlsApp.Worksheets(Cnt)
　　　　　　　　xlsWkb.ActiveSheet.Name = MyDate
　　　　　　End If
　　　　　　
'シートへの書き込み
　　　　　　Set xlsSht = xlsWkb.Sheets(MyDate)
　　　　　　For Cnt = 1 To RS.Fields.Count
　　　　　　　　xlsSht.Cells(1, Cnt).Value = RS.Fields(Cnt - 1).Name
　　　　　　Next
　　　　　　xlsSht.Range("A2").CopyFromRecordset RS
　　　　　　xlsWkb.Save
　　　　　　xlsWkb.Close: Set xlsSht = Nothing: Set xlsWkb = Nothing
　　　　　　xlsApp.Quit: Set xlsApp = Nothing
　　　　　　RS.Close
　　　　　　Set RS = Nothing
　　　　End If
End Sub

2,502 hits

▼

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