以下のマクロは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ランキング
-
FF11が強制終了に・・・
-
PowerShellを使って関連付けら...
-
DisplayAlertsブロパティで ”実...
-
cube PDFについて
-
gccを行ってもexeファイルが生...
-
ASPからACCESSのOPENどうしても...
-
ファイル アクセス権のエラーの...
-
FORTRANの実行エラーについて
-
画像読み込み失敗の判定
-
NAS上のファイルの使用中が解除...
-
ADOを使用してExcelファイルを...
-
EXCEL VBAで複数人でのADO接続...
-
「パス名が無効です」の発生原因
-
freadでデータがない場合の読込...
-
batファイルでレジストリキーの...
-
エクセル VBA dll 読み込...
-
EXCELVBAでONEDRIVE上への保管...
-
FTPの送信結果を検知したい
-
Adobeのプレミアプロの書き出し...
-
RAR圧縮ファイル(分割)の順番が...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBでファイルが開かれているか...
-
batファイルでレジストリキーの...
-
gccを行ってもexeファイルが生...
-
「パス名が無効です」の発生原因
-
Returnに対するGoSubがありません
-
アクセスのクエリでコンパイル...
-
NAS上のファイルの使用中が解除...
-
VBから参照できないCのDLLを使...
-
PowerShellを使って関連付けら...
-
Adobeのプレミアプロの書き出し...
-
EXCELのVBAでWORDが開いてある...
-
FTPの送信結果を検知したい
-
access テキストボックスの値取得
-
エクセルマクロでエラーの原因...
-
【COBOL】read文でエラー
-
VB6 Dir関数で52エラー発生
-
VBA ExecuteExcel4Macro 型が一...
-
Access2013にてドラッグ&ドロ...
-
freadでデータがない場合の読込...
-
ファイルクローズ(fclose)でエ...
おすすめ情報