<困っていること>
1回目は正常終了しますが続けて2日目を実行すると「オブジェクト変数またはWithブロック変数が設定されていません」というエラーが発生します。
タスクマネージャで確認するとExcelのプロセスが残っており、これが原因のようです。
<実施したいこと>
事前に用意しているtemplate.xlsxがあります。
Access内で集計した結果をtemplate.xlsxの"データ"シートに貼り付け、
"表"シートのA1セルへ店番をセットし再計算して"csv用"シートの内容をcsvファイル店舗数分作成したい。
途中エラー判定処理があり、エラーの場合はExcelのまま保存したい(後ほど開いて計算結果を確認できるようにしたいため)
<試したこと>
赤字のcsvでの保存をコメントして実行すると問題がないため
赤字の書き方が悪いのかと思っています。
どなたかどうぞご教授よろしくお願いいたします。
Function MakeReport_Start()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim objExcelApp As Excel.Application
Dim objWB As Excel.Workbook
Dim ws As Excel.Worksheet
Dim SaveFileDir As String
Dim SaveFileNM As String
Dim ErrFlg As Integer 'エラー判定フラグ
On Error GoTo ErrHandle
'テンプレートファイルオープン
strFilePath = CurrentProject.Path & "\Template.xlsx"
Set objExcelApp = CreateObject("Excel.Application")
Set objWB = objExcelApp.Workbooks.Open(strFilePath)
objExcelApp.Application.Visible = False
objExcelApp.ScreenUpdating = False
objExcelApp.Application.DisplayAlerts = False
objExcelApp.Calculation = xlCalculationManual '手動計算
'店舗数分ループ
Set DB = CurrentDb
Set RS = DB.OpenRecordset("店舗一覧")
Do While Not RS.EOF
Set ws = objWB.Worksheets("表")
With ws
.Cells(3, "D") = RS("店舗コード").Value
'------ Excel関数を使用して集計処理 ---------
objExcelApp.Calculate '再計算
'マイナスがある場合エラー
ErrFlg = 0
If objExcelApp.WorksheetFunction.CountIf(.Range("K7:K48"), "<0") > 0 Then
ErrFlg = 1
End If
End With
'エラーの場合Excelファイルのまま保存､エラーがない場合はcsvファイルを保存
SaveFileDir = "C:\Users\masumi taira\Desktop\Template\Out"
If ErrFlg = 1 Then
objExcelApp.Calculation = xlCalculationAutomatic '自動計算
SaveFileNM = SaveFileDir & "\" & RS("店舗コード").Value & ".xlsx"
objWB.SaveAs SaveFileNM
Else
SaveFileNM = SaveFileDir & "\" & RS("店舗コード").Value & ".csv"
objWB.Worksheets("csv用").Copy
ActiveWorkbook.SaveAs FileName:=SaveFileNM, FileFormat:=xlCSV ', Local:=True
ActiveWorkbook.Close
End If
RS.MoveNext
Loop
objExcelApp.Calculation = xlCalculationAutomatic '自動計算
objWB.Close SaveChanges:=False: Set objWB = Nothing
objExcelApp.Quit: Set objExcelApp = Nothing
Finally:
If Not objWB Is Nothing Then objWB.Close: Set objWB = Nothing
If Not objExcelApp Is Nothing Then objExcelApp.Quit: Set objExcelApp = Nothing
If Not RS Is Nothing Then RS.Close: Set RS = Nothing 'Recordset解放
If Not DB Is Nothing Then DB.Close: Set DB = Nothing
Exit Function
ErrHandle:
' Call ErrDisp(Err.Number, Err.Description)
Resume Finally
End Function
