複数のExcelファイルの全シートを全部Docuworksにするマクロの「メモリが足りません」を解消したつもり。

昨年、苦し紛れに作ったExcelのシート全部印刷しちゃおうマクロなんだが、欠点がある。

複数のExcelファイルの全シートを全部Docuworksにしたいのでマクロをパクった | 地質屋さんと呼ばないで

こいつでかいファイルを多量に扱うと、「メモリが足りません」がでて白いシートを吐き出しままお亡くなりになります。

このまま今年も使い続けるのは馬鹿なので少し改良することにした。

元のマクロ。

/*Sub 一括印刷()

'ダイアログで印刷対象ブックを開く（複数ファイル指定可）
Dim FileName As Variant
FileName = Application.GetOpenFilename _
("Microsoft Excelブック,*.xls?", MultiSelect:=True)

If Not IsArray(FileName) Then
Exit Sub
End If

Dim cnt As Long '選択ファイル数のカウント
cnt = UBound(FileName)

Dim rc As Long '実行確認
rc = MsgBox(cnt & "ファイルが選択されました。" & vbCrLf & _
"印刷を開始しますか？", vbOKCancel + vbInformation)

If rc = vbOK Then

Dim n As Long '印刷対象のブック数
For n = LBound(FileName) To UBound(FileName)

Dim wb As Workbook '印刷対象ブック
Set wb = Workbooks.Open(FileName(n))

ActiveWorkbook.PrintOut Preview:=False '全シート印刷

wb.Close False '保存しないで閉じる

Next n

MsgBox "印刷終了しました。"

End If

End Sub
*/

これだとメモリーを解放する前に次のファイルを掴みに言ってしまうので、パンクするらしいのだ。

/*Sub 一括印刷()

'ダイアログで印刷対象ブックを開く（複数ファイル指定可）
Dim FileName As Variant
FileName = Application.GetOpenFilename _
("Microsoft Excelブック,*.xls?", MultiSelect:=True)

If Not IsArray(FileName) Then
Exit Sub
End If

Dim cnt As Long '選択ファイル数のカウント
cnt = UBound(FileName)

Dim rc As Long '実行確認
rc = MsgBox(cnt & "ファイルが選択されました。" & vbCrLf & _
"印刷を開始しますか？", vbOKCancel + vbInformation)

If rc = vbOK Then

Dim n As Long '印刷対象のブック数
For n = LBound(FileName) To UBound(FileName)

Dim wb As Workbook '印刷対象ブック
Set wb = Workbooks.Open(FileName(n))

ActiveWorkbook.PrintOut Preview:=False '全シート印刷

wb.Close False '保存しないで閉じる

'Close待機←ここから追加した
DoEvents

Next n

MsgBox "印刷終了しました。"

End If

End Sub
*/

31～32行を追加した。

これで、大量の重たいExcelファイルを10個でも20個でも全部Docuworksにすることが出来るようになった。

でもバックグラウンドでChrome使ってネットサーフィンとかTwitterとかしない方が良さそうな感じ。

あとは、これをやったあとはExcelを再起動しないと、また落ちます。

最後の尻に、「DoEvents」させたらいいの？よく解らないけど、まあこのままで行こう。

謝辞）以下の先輩を参考にいたしました。

VBAでExcelファイル開閉を繰り返すと、徐々に遅延が発生する不具合を解消（メモリ解放） – Qiita

（2022/02/18追記）

なんか変な挙動を起こしてハングアップするようになったが、15個くらいのファイルは機嫌が良ければ動くのでOKとします。

昨年よりは能率はたぶん3倍あっぷしたぞ。

Follow me!