| |
▼にしもり さん：
こんにちは。
>もうすこし自分の力で研究してみたいと思います。
【4919】Re:既存のExcelファイルにエクスポートするには
のコードを少し改変してあります。
少しでも研究のお力になれれば幸いです。
Sub xlsOut2()
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 ShtName As String
Dim MySheet As Variant
Dim Cnt As Long
Dim FLG As Boolean
'出力するテーブル、出力先ファイルの指定
MyFile = "C:\回数_埼玉.xls"
MyTBL = "回数_当月"
ShtName = "回数_4月"
'MyFileの存在チェック
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not (FSO.FileExists(MyFile)) Then
'MyFileがなかった時はそのままエクスポート
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel9, MyTBL, MyFile, True
'シートの名前を変更
Set xlsWkb = xlsApp.Workbooks.Open(MyFile)
xlsWkb.Sheets(MyTBL).Name = ShtName
xlsWkb.Save
xlsWkb.Close: Set xlsWkb = Nothing
xlsApp.Quit: Set xlsApp = Nothing
Else
'MyFileがあった時はレコードセットにMyTBLの値を代入
Set RS = CurrentDb.OpenRecordset(MyTBL, dbOpenDynaset)
Set xlsWkb = xlsApp.Workbooks.Open(MyFile)
'同名のシートの検索
FLG = False
For Each MySheet In xlsWkb.Sheets
If MySheet.Name = ShtName Then
FLG = True
Exit For
End If
Next
'同名のシートがあった場合は全クリア、
'無かった場合はブックの最後にシートを追加
If FLG Then
xlsWkb.Sheets(ShtName).Cells.ClearContents
Else
Cnt = xlsWkb.Sheets.Count
xlsWkb.Sheets.Add after:=xlsApp.Worksheets(Cnt)
xlsWkb.ActiveSheet.Name = ShtName
End If
'シートを開く
Set xlsSht = xlsWkb.Sheets(ShtName)
'シートの１行目はフィールドの名前を書き込む
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
|
|
![[未読]](./data/access/image/read_icon.gif){kind=icon}
