dポイントプレゼントキャンペーン実施中!

以下のマクロはExcelファイルを開いたときに自動で画像を貼り付けるマクロです。
(excelファイル 閉じた時に画像いったん削除する仕組みだったんですが、削除部分のマクロはここには書いていません)
Excelファイルと同じ階層にある、Range("A1")と同じ名前のフォルダにある画像を参照し、
Excelファイルを開いた同時にtargetrange に入力されている名前と同じ名前の画像ファイルをmyRangeに貼り付ける仕組みになっています。
問題点:今現在targetrangeに入力されている名前と同じ名前画像ファイルがすべてあればexcel ファイルっを開いた時に画像は正確に貼り付けることはできますが、同じ名前の画像は一部でもない場合はエラーになります。
エラー解消するために On Error Resume Next 入れたんですが、エラーはなくなりますが、
誤作動します。
添付画像の上は原爆ドーム近景の写真がない状態でマクロ実行されたものですが、近景の写真がないのに遠景の写真は近景に貼っています。
On Error Resume Next せいだと思いますが、直し方がわかりません。教えてください!
よろしくお願いします。

’-----------------------マクロ内容ここから-------------------------
Private Sub Workbook_Open()
Dim shape As shape
Dim FileName As String
Dim FolderName As String
Dim PicPath As String
Dim myRange As Range
Dim rX As Double, rY As Double
Dim objShape As shape
PicPath = ThisWorkbook.Path & "\"
FolderName = Range("A1").Value
'1--------------------------------------------------
Set myRange = Range("A2:D11")
Set targetrange = Range("A12")
On Error Resume Next
Set objShape = ActiveSheet.Shapes.AddPicture( _
FileName:=PicPath & FolderName & "\" & targetrange & ".jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, _
Top:=1, _
Width:=0, _
Height:=0)

Application.ScreenUpdating = False
With objShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue

rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange.Left + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With

Application.ScreenUpdating = True
Cancel = True
On Error GoTo 0
'2----------------------------------------------
Set myRange = Range("F2:I11")
Set targetrange = Range("F12")
On Error Resume Next
Set objShape = ActiveSheet.Shapes.AddPicture( _
FileName:=PicPath & FolderName & "\" & targetrange & ".jpg", _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=1, _
Top:=1, _
Width:=0, _
Height:=0)

Application.ScreenUpdating = False
With objShape
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue

rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
.Width = .Width * rY
Else
.Height = .Height * rX
.Width = .Width * rX
End If
.Left = myRange.Left + (myRange.Width - .Width) / 2
.Top = myRange.Top + (myRange.Height - .Height) / 2
End With

Application.ScreenUpdating = True
Cancel = True
On Error GoTo 0
End Sub
'ここまで

「Excel VBAエラー処理について教え」の質問画像

A 回答 (3件)

No.1の者です。



誤字:チャック → 正しく:チェック

例えば、
If Dir(PicPath & FolderName & "\" & targetrange & ".jpg") <> "" Then
*** 貼り付け処理 ***
End If
    • good
    • 1
この回答へのお礼

御礼が遅くなりました、申し訳ございません。早急に回答頂きありがとうございました。ファイルがあるかどうかチェックの仕方が分わからなかったんですが、If Dir() <> "" Then の使い方がよく理解できました。
助かりました。本当にありがとうございました。

お礼日時:2021/10/05 14:44

こんばんは、


既に適切な回答が出ていますので、直接の回答ではありません。

初めに貼り付けた画像がRange("F2:I11")に貼り付く理由は
2---のところで
Application.ScreenUpdating = False
With objShape
以下が実行され移動する為です。なので、
2---に入る前に Set objShape = Nothing とすればエラーは続き
期待する形にはなると思います。

しかし、エラー対策をしているとはいいがたく、良くない方法ですね。
既に回答のあるようにファイルの所在を確かめて実行するのがベストです

また、On Error Resume Next を他の理由で使用したい時などは、
If Err.Number <> 0 Then GoTo 飛ばしたいラベル などを設定して
次の実行コードに飛ばす方法を合わせて使うのが良いと思います。

あと、、、ごめんなさい
targetrangeはsetや変数名からRangeだと理解できるのですが
文字列の指定にValueを省略して入れるのはあまり良くないかな、、
まあ、自身が分かれば良いけれど、、

さらに、同じような処理を2度繰り返す形になっているようなので
Set myRange = Range("A2:D11")
Set targetrange = Range("A12") にOffsetを加えてループで
処理すると後で3,4枚増やしたい場合に簡単だと思います。
余計な事まで書いたので、その部分の一応サンプルです
Dim n As Integer
For n = 0 To 5 Step 5
Set myRange = Range("A2:D11").Offset(, n)
Set targetrange = Range("A12").Offset(, n)
If Dir(PicPath & FolderName & "\" & targetrange.Text & ".jpg") <> "" Then
Set objShape = ActiveSheet.Shapes.AddPicture( _
FileName:=PicPath & FolderName & "\" & targetrange & ".png", _

Next
2---以下End Subまで不要
枚数でループの方が良かったかも、、
    • good
    • 1
この回答へのお礼

御礼が遅くなりました、申し訳ございません。丁寧に説明していただきありがとうございます。いろいろと勉強になりました。固定の様式に何百枚の写真を貼り付けるので、すべての枚数に対して同じマクロ書いていくのはバカバカしいと自分でも思ったんですが、VBAに対しては初心者なので出来なかったです。教えて頂いたサンプルを参考にして頑張って作っていきたいと思います。本当にありがとうございました。
ベストアンサーに選びたい気持ちですが、No.1さんが先に答えを書いているので、そちらをベストアンサーに選んでいただきます。申し訳ございません。

お礼日時:2021/10/05 14:34

こんばんは。



エラー処理よりも、事前にファイルがあるかをチャックし、なければ、
 貼り付ける処理をしない方が良いかと思います。

Dir関数
https://excel-ubara.com/excelvba1/EXCELVBA379.html
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!