| |
▼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
|
|
nemotake
- 05/4/20(水) 13:04 -
小僧
- 05/4/20(水) 11:56 -
小僧
- 05/4/20(水) 9:49 -
にしもり
- 05/4/19(火) 10:08 -
- 05/4/16(土) 11:07 -
