
以下のマクロは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
'ここまで

No.2ベストアンサー
- 回答日時:
No.1の者です。
誤字:チャック → 正しく:チェック
例えば、
If Dir(PicPath & FolderName & "\" & targetrange & ".jpg") <> "" Then
*** 貼り付け処理 ***
End If
御礼が遅くなりました、申し訳ございません。早急に回答頂きありがとうございました。ファイルがあるかどうかチェックの仕方が分わからなかったんですが、If Dir() <> "" Then の使い方がよく理解できました。
助かりました。本当にありがとうございました。
No.3
- 回答日時:
こんばんは、
既に適切な回答が出ていますので、直接の回答ではありません。
初めに貼り付けた画像が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まで不要
枚数でループの方が良かったかも、、
御礼が遅くなりました、申し訳ございません。丁寧に説明していただきありがとうございます。いろいろと勉強になりました。固定の様式に何百枚の写真を貼り付けるので、すべての枚数に対して同じマクロ書いていくのはバカバカしいと自分でも思ったんですが、VBAに対しては初心者なので出来なかったです。教えて頂いたサンプルを参考にして頑張って作っていきたいと思います。本当にありがとうございました。
ベストアンサーに選びたい気持ちですが、No.1さんが先に答えを書いているので、そちらをベストアンサーに選んでいただきます。申し訳ございません。
No.1
- 回答日時:
こんばんは。
エラー処理よりも、事前にファイルがあるかをチャックし、なければ、
貼り付ける処理をしない方が良いかと思います。
Dir関数
https://excel-ubara.com/excelvba1/EXCELVBA379.html
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- PowerPoint(パワーポイント) ExcelのVBAコードについて教えてください。 3 2022/05/25 14:32
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Visual Basic(VBA) Excel vbaについての質問 3 2023/04/18 16:14
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) ①ExcelVBAでカレンダーを作り、別のユザーフォームで日付を入力したいのですがエラーになります。 1 2023/02/17 18:39
- Excel(エクセル) エクセルで同じ数字同士を自動で線で結ぶVBAを教えてください 6 2022/04/26 23:13
- Visual Basic(VBA) エクセルVBAで以下のようなコードを書いたらエラーになりました。何処が間違っているの教えて? 1 2023/02/10 18:30
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【関数】同じ関数なのに、エラ...
-
access テキストボックスの値取得
-
「パス名が無効です」の発生原因
-
DisplayAlertsブロパティで ”実...
-
Adobeのプレミアプロの書き出し...
-
NAS上のファイルの使用中が解除...
-
データベースソフトのアクセス2...
-
fgets関数のEOFの扱い方について
-
【COBOL】read文でエラー
-
エクセルマクロでエラーの原因...
-
PowerShellを使って関連付けら...
-
VBから参照できないCのDLLを使...
-
Excel 2003 のエラーメッセージ
-
Returnに対するGoSubがありません
-
VBでファイルが開かれているか...
-
アクセスのクエリでコンパイル...
-
ExcelVBAで既に開いてるwordを...
-
gccを行ってもexeファイルが生...
-
ファイルクローズ(fclose)でエ...
-
すでにファイルが開かれている...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
【関数】同じ関数なのに、エラ...
-
access テキストボックスの値取得
-
「パス名が無効です」の発生原因
-
ExcelVBAで既に開いてるwordを...
-
NAS上のファイルの使用中が解除...
-
Returnに対するGoSubがありません
-
gccを行ってもexeファイルが生...
-
PowerShellを使って関連付けら...
-
batファイルでレジストリキーの...
-
アクセスのクエリでコンパイル...
-
VB6 Dir関数で52エラー発生
-
エクセルマクロでエラーの原因...
-
VBでファイルが開かれているか...
-
【COBOL】read文でエラー
-
FTPの送信結果を検知したい
-
VBから参照できないCのDLLを使...
-
fgets関数のEOFの扱い方について
-
ACCESS VBAでのインポート
-
データベースソフトのアクセス2...
-
DisplayAlertsブロパティで ”実...
おすすめ情報