AccessVBAでのExcelメモリ解放
はじめまして。
仕事でAccessVBAを使ってExcelのデータを操作するプログラムを作っています。
やりたいこと
(1)日付と店番・店名が入力されているExcelを開く
(2)削除日=C列からオートフィルで空白（日付が入力されていないもの）を絞りだす
(3)日付=B列からオートフィルで本日の日付より１ヶ月前の日付を搾り出す
(4)もし本日より１ヶ月前の日付があれば、C列の削除日に本日の日付を入れる
(5)印刷
問題点
・動作が不安定
・Excelのメモリ解放がおかしいのか、プログラム終了後別件でエクセルを開くと
ビジー状態になり「応答なし」になってしまう
・プログラム内でAccessテーブルのデータを既存のExcelファイルの最終行に
追加で出力したいが、なぜかAccessテーブルの名前で新規シートが作られ、そこに
データが入ってしまう
色々なサイトを見ましたが、どこがおかしいのか分からず。
どなたか知恵をお貸しいただけますでしょうか。
Private Sub cmd_insert_Click()
On Error GoTo Error
Dim App As Object ' Application Object
Dim Wkb As Object ' Excel.Workbook Object
Dim Wsh As Object ' Excel.WorkSheet Object
Dim Kensu As Integer ' 削除データ件数格納
Dim cnt As Integer ' 件数カウント
Dim lngYLine As Long ' 対象となる列の番号
Dim intXLine As Integer ' 対象となる行の番号
Dim strac As String ' Accessテーブル名
Dim strxls As String ' 出力先ファイルのパス
Dim strmsg As String ' メッセージボックスへのメッセージ格納
Dim strans As String ' 削除対象日付格納
'Excelファイルをセット
Set App = CreateObject("Excel.Application")
App.Visible = True
Set Wkb = App.WorkBooks.Open("C:\Downloads\記録.xls") ←わざと変なURLにしています
Set Wsh = Wkb.Worksheets("HP")
'出力先ファイル指定
strxls = "C:\Downloads\記録.xls"
'Accessテーブルに入力したデータをExcelファイルへ出力
strac = "tbl_募集データ"
strmsg = strac & " を、Excelファイルへ出力します。" & Chr(13) & _
"出力先は" & strxls & "、 シート名はHPです。" & _
Chr(13) & "よろしければ、OKをクリックして下さい。"
'★★excelシートの最終行に追加でデータを入れたい★★
' If MsgBox(strmsg, vbOKCancel) = vbOK Then
'
'
' '最初のデータをフィールド名として使う
' DoCmd.TransferSpreadsheet acExport, _
' acSpreadsheetTypeExcel9, strac, strxls, True
' MsgBox "データ入力正常完了！"
'
' End If
'オートフィルで「削除日」の行が空白のものを選択 ※削除日はC行目固定とする
Wsh.Range("C1").CurrentRegion.AutoFilter Field:=3, Criteria1:="="
'本日分の削除データのチェック（本日より１ヶ月前の日付のものを搾り出す）
strans = Format(DateAdd("d", -30, Date), "mm/dd")
Wsh.Range("B1").CurrentRegion.AutoFilter Field:=2, Criteria1:=strans
If Wsh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "本日は削除データがありません"
Else
'削除データ件数取得
Kensu = (Wsh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count) - 1
MsgBox "削除データあり、件数は" & Kensu & "件でした"
lngYLine = Wsh.Cells.Find(strans).Row
intXLine = Wsh.Cells.Find(strans).Column
For cnt = 1 To Kensu
'削除日の列に本日の日付を入力
Wsh.Range("C" & CStr(lngYLine)).Value = Format(Date, "mm/dd")
lngYLine = lngYLine + 1
Next
'削除対象範囲を印刷
If MsgBox("印刷しますか？", vbQuestion + vbYesNo) = vbYes Then
'シートの指定
Wsh.Activate
App.Visible = False
Wkb.Application.ScreenUpdating = False
Wsh.Visible = True
Wsh.PrintOut
Wsh.Visible = False
End If
End If
'オートフィルを元に戻す
If Wsh.FilterMode = True Then
Wsh.ShowAllData
End If
MsgBox ("正常終了しました！")
'上書き保存
Wkb.Save
'Only XL 97 supports UserControl Property
On Error Resume Next
'App.UserControl = True
Wkb.Close SaveChanges:=False
App.Quit
Set Wsh = Nothing
Set Wkb = Nothing
Set App = Nothing
Exit Sub
Error:
If Err.Number = 3044 Then
MsgBox "パスの指定が誤っている可能性があります。", vbCritical
Else
MsgBox "予期せぬエラーが発生しました。", vbCritical
End If
App.UserControl = True
Wkb.Close
App.Quit
Set Wsh = Nothing
Set Wkb = Nothing
Set App = Nothing
End Su
お礼
taka_tetsu様 丁寧なご回答ありがとうございます。 おかげでストリームの概念から調べることが出来、大方の理解をすることができました。 大変参考になりました！