| |
こんばんは、
Access2013の環境で、古いバージョンのVBAが動かなくて、試行錯誤で
やってみましたが、うまくいきません。
助けて下さい！よろしくお願いします。
問題点：Access2013/Excel2013環境で、以下のVBAを実行すると、xlsWkb.SaveAs OutFileのところ黄色反転
--------------------------------------------------------------------------
Function ExcelExport()
'※要参照 Microsoft DAO x.x Object Library
Const TName = "分布_003" 'データの入っているテーブル名
Const OutFile = "C:\分析データ.xls" 'エクスポート先 Excelファイル名
Dim RS1 As DAO.Recordset
Dim RS2 As DAO.Recordset
Dim strSQL1 As String
Dim strSQL2 As String
Dim xlsApp As Object
Dim xlsWkb As Object
Dim xlsSht As Object
Dim i As Long
Dim RetVal As Variant
RetVal = SysCmd(acSysCmdSetStatus, "【分析データ】出力中・・・しばらくお待ち下さい")
On Error Resume Next
Kill OutFile
On Error GoTo 0
Set xlsApp = CreateObject("Excel.Application")
Set xlsWkb = xlsApp.Workbooks.Add
strSQL2 = "SELECT DISTINCT 分布エリア FROM " & TName
Set RS2 = CurrentDb.OpenRecordset(strSQL2, dbOpenSnapshot)
Do Until RS2.EOF
Set xlsSht = xlsWkb.Worksheets.Add
xlsSht.Name = RS2![分布エリア]
strSQL1 = "SELECT * FROM " & TName _
& " WHERE 分布エリア = '" & RS2![分布エリア] & "';"
Set RS1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
For i = 1 To RS1.Fields.Count
xlsSht.Cells(1, i).Value = RS1(i - 1).Name
Next
xlsSht.Range("A2").CopyFromRecordset RS1
xlsSht.Range("A1").CurrentRegion.Columns.AutoFit
xlsSht.Range("A1").CurrentRegion.Rows.AutoFit
RS1.Close
Set RS1 = Nothing
RS2.MoveNext
Loop
Set RS1 = Nothing
RS2.Close: Set RS2 = Nothing
On Error Resume Next
For i = 1 To 3
xlsWkb.Sheets("Sheet" & i).Delete
Next
On Error GoTo 0
Set xlsSht = Nothing
'
'↓黄色反転。Access2003/Excel2003の時、問題なかった。
xlsWkb.SaveAs OutFile
xlsWkb.Close: Set xlsWkb = Nothing
xlsApp.Quit: Set xlsApp = Nothing
MsgBox "終了しました。"
End Function
--------------------------------------------------------------------------
|
|
![[未読]](./data/access/image/read_icon.gif){kind=icon}
