Excel vbaについての質問

ほとんどが実行できますが時折エラーが出て中断されます。

エラー時の文章：実行時エラー 1004 rangeクラスのcopypictureメソッドが失敗しました。

エラーが起きる場所も毎回バラバラで、本来はタスクスケジューラで毎時自動で実行したいものなのでエラーが何とか起きないようにしたいです。
エラーが起きる場所は主に各範囲のpic.Chart.Pasteか、
各範囲それぞれのexportRange2.CopyPicture Appearance:=xlScreen, Format:=xlPicture
この部分です。
助けてほしいですお願いします。

Private Sub Workbook_Open()
Dim FileSize As Long
Dim pic As ChartObject
Dim picName As String
Dim picName2 As String
Dim picName3 As String
Dim picName4 As String
Dim rng As Range
Dim exportRange2 As Range
Dim exportRange3 As Range
Dim exportRange4 As Range
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim path As String
Dim retryCounter As Integer
path = "C:\???\???\???\???\???\???\"

Application.DisplayAlerts = False

Application.ScreenUpdating = False

For Each ws In Worksheets
Select Case ws.Name

Case "報告書"
picName = path & "image" & "1.png"
Set rng = ws.Range("D4:N52")

Application.Wait (Now + TimeValue("0:00:01"))
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set pic = ws.ChartObjects.Add(0, 0, rng.Width, rng.Height)
pic.Name = "ChartObject3"
pic.Chart.Export picName
FileSize = FileLen(picName)

If FileLen(picName) <= FileSize Then
pic.Chart.Paste
pic.Chart.Export picName
End If

pic.Delete
Set pic = Nothing

Case "グラフ"
'範囲1
picName2 = path & "image" & "2.png"
Set exportRange2 = ws.Range("A1:Y35")

Application.Wait (Now + TimeValue("0:00:01"))
exportRange2.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set pic = ws.ChartObjects.Add(0, 0, exportRange2.Width, exportRange2.Height)
pic.Name = "ChartObject2"
pic.Chart.Export picName2
FileSize = FileLen(picName2)

If FileLen(picName2) <= FileSize Then
pic.Chart.Paste
pic.Chart.Export picName2
End If

pic.Delete
Set pic = Nothing

'範囲2
picName3 = path & "image" & "3.png"
Set exportRange3 = ws.Range("A36:Y70")

Application.Wait (Now + TimeValue("0:00:01"))
exportRange3.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set pic = ws.ChartObjects.Add(0, 0, exportRange3.Width, exportRange3.Height)
pic.Name = "ChartObject3"
pic.Chart.Export picName3
FileSize = FileLen(picName3)

If FileLen(picName3) <= FileSize Then
pic.Chart.Paste
pic.Chart.Export picName3
End If

pic.Delete
Set pic = Nothing

'範囲3
picName4 = path & "image" & "4.png"
Set exportRange4 = ws.Range("A71:Y105")

Application.Wait (Now + TimeValue("0:00:01"))
exportRange4.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set pic = ws.ChartObjects.Add(0, 0, exportRange4.Width, exportRange4.Height)
pic.Name = "ChartObject4"
pic.Chart.Export picName4
FileSize = FileLen(picName4)

If FileLen(picName4) <= FileSize Then
pic.Chart.Paste
pic.Chart.Export picName4
End If

pic.Delete
Set pic = Nothing
Case Else
GoTo NextSheet
End Select

NextSheet:
Next ws

ThisWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Quit
End Sub

No.3 回答者： Qchan1962 回答日時： 2023/04/19 17:21

こんにちは

＃２様ご指摘の部分だと思いますがApplication.Wait (Now + TimeValue("0:00:01"))　をなくして
簡単なデモVBAで実行してみましたが1004エラーが出ず検証できませんでした
従ってエラールーチンで繰り返せば解消できるのか・・それとも無限ループになるのか・・・明確な対策案を掲示できません

ただ、Private Sub Workbook_Open()イベントで実行しているようなので
実行を少し下位で実行するのはどうでしょう
ExcelからVBA実行ではないようなので
Auto_Open()で検証用VBAを書いて見ました・・・（Shift+）で回避できるのでテストにはいいかなと・・

念のためActivateやParent.Select、DoEventsなどを加えました
標準モジュールModule1に書き直しています

Sub Auto_Open()
Worksheets(1).Activate
Call Module1.AutoSaveToPNG
End Sub

Private Sub AutoSaveToPNG()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Const path As String = "C:\???\???\???\???\???\???\"
Const image1 As String = "image1.png"
Const image2 As String = "image2.png"
Const image3 As String = "image3.png"
Const image4 As String = "image4.png"

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each ws In Worksheets
ws.Activate
Select Case ws.Name
Case "報告書"
Call CopyRangeToPNG(ws.Range("D4:N52"), path & image1)
Case "グラフ"
'範囲1
Call CopyRangeToPNG(ws.Range("A1:Y35"), path & image2)
'範囲2
Call CopyRangeToPNG(ws.Range("A36:Y70"), path & image3)
'範囲3
Call CopyRangeToPNG(ws.Range("A71:Y105"), path & image4)
Case Else
GoTo NextSheet
End Select
NextSheet:
Next ws
Worksheets(1).Activate
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Quit
End Sub

Sub CopyRangeToPNG(ByRef rng As Range, ByVal picName As String)
Dim FileSize As Long
Dim pic As ChartObject
Dim tmpChart As Object
rng.CopyPicture xlPrinter, xlPicture
Application.Wait (Now + TimeValue("0:00:03"))
DoEvents
Set pic = ActiveSheet.ChartObjects.Add(0, 0, rng.Width, rng.Height)
pic.Name = "ChartObject3"
With pic.Chart
.Parent.Select
.Export picName
FileSize = FileLen(picName)
If FileLen(picName) <= FileSize Then
Application.Wait (Now + TimeValue("0:00:03"))
DoEvents
.Paste
.Export picName, Filtername:="png"
End If
.Parent.Delete
End With
Set pic = Nothing
End Sub

No.2 回答者： ssawatake 回答日時： 2023/04/18 17:11

CopyPictureメソッドはセル範囲のコピーを行い即座に図に変換してクリップボードに送る仕組みです。

が、この「セル範囲のコピー完了前に次の処理に入ってしまいエラーとなると考えると良いかと思います。

PCのバック処理が色々動いてるので、1秒待つのでは足り無い場合が出てくる筈です。
なので、上手く行く時も有るし・・・です。

待ち時間をもう少し長くするとか、「On Error Goto ～」と「Resume ～」を使い、エラー発生時にはコピー直前のラベルにResumeして、もう1回。

とするしか無いと思います。

とにかく、「ピッタリ同期して動け」と言う命令文がVBAには有りませんので・・・。

No.1 回答者： Zincer 回答日時： 2023/04/18 16:40

すみません。

まだ全部を把握できてはいませんが、チョクチョク現われる
＞FileSize = FileLen(picName?)
＞If FileLen(picName?) <= FileSize Then
＞・・・
＞End If
のIf分は機能していません（＝必ずTrueになる）がよろしいのでしょうか？
また、このようなページを見つけましたので、参考にしてください。

セル範囲を画像としてコピーする【CopyPictureメソッド】【ExcelVBA】
https://vba-create.jp/vba-method-copypicture/