エクセルVBAで複数のセル入力からそれぞれの画像を指定したセルに貼り付け

質問

複数のセル入力時のたびに自動実行されるイベントマクロを使い、それぞれの入力値と同じ画像を決まったセルに貼り付けようとするVBAをつくろうとしています。
画像サイズ加工（サイズ調整、トリミング）は同じものとします。
更に、画像がないセルに関しては、画像が挿入されるそれぞれのセルに
”画像登録がありません”と表示される。

入力セル=B3:B10 画像挿入セル＝F2,F9,F16,F23,F30,F37,F44,F51

できれば、勉強の為に’コメント説明付のご回答をお願いします。

回答No.3

Wendy02 · ベストアンサー

こんにちは。

>到底たどり着けないコードでした。

VBA力というのかな、囲碁などで言う、棋力と同じようにいうなら、それをすべてを組み入れられるのは、２段クラスぐらいかな？（どこかの県知事の名目剣道２段とはちょっと違います)　半年や１年のレベルでは、無理だと思います。ただ、この範囲は、掲示板での回答の範囲です。（そうでない場合は、お断りしているケースもあります)

でも、世の中は広いというか、怖いもので、プログラミングの経験がなくても、数ヶ月であっけなく上位クラスまで到達するような人もいます。ただ、一般的に簡単なBASIC コードでも、使いこなせられる人は、１０人に１人だといわれていました。そういう私は、もうWindowsも扱うことはなかろうと思っていたのが、あるきっかけで、使い始めて、VBAも紆余曲折で覚えました。しかし、今、何年やっても、１週間もやっていないと、VBAがさび付いてきます。毎日のように、VBAのコードを触っていないとダメなのです。年のせいか、すべてのレベルが下降中です。（ここ数ヶ月パワーダウンしてしまっています)

>多くの変数宣言が必要なのですね。
掲示板のVBAの継続している回答者として、変数を宣言しないのは、みっともないのです。そうしないと指摘されることがあるからです。

>・入力セルとは、何を入れるのでしょうか？
>　セルへの入力内容は、画像のファイル名を入力します
了解しましたが、もっとややこしいですね（^^;

>・次に、画像は一定のものですか？
>　一定のもので、"D:\写真\"というフォルダに複数の画像”・・・・.jpg"が入って　います。
上の条件で、了解です。

>・画像が挿入される、という判定を画像でするのでしょうか？
>　判定は、入力セルの値と画像のファイル名の合致でおこないます。
>画像の判定で更に変数が必要でしょうか。

　変数自体は関係がありませんが、画像の判定の件は、ちょっと保留にしていただきたいのです。理由は、ファイル名は、AlternativeTextに書き込むようにしましたが、今の段階では、セル位置の対応があるようですから、セル位置の対応にしました。問題があるようなら、おっしゃってください。今のコードでは、画像を移動すると、処理できなくなります。画像のNameプロパティには入れるのはやめました。同じものを入れると、ぶつかってしてしまうからです。

'シートモジュール
'--------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Long
　　Dim PicName As String
　　Dim pic As Picture
　　Dim arAD As Variant
　　Dim c As Variant
　　'画像の場所
　　Const PICPATH As String = "D:\写真\"
　　'挿入セルの場所
　　Const arADD As String = "F2,F9,F16,F23,F30,F37,F44,F51"

　　arAD = Split(arADD, ",")

　　If Target.Count > 1 Then Exit Sub
　　If Intersect(Target, Range("B3:B10")) Is Nothing Then Exit Sub
　　i = (Target.Row - 3) * 7 + 2

　　Application.ScreenUpdating = False
　　If Target.Value <> "" Then
　　　 PicName = Target.Value
　　　 '拡張子の判定
　　　 If InStr(1, PicName, ".jpg", 1) = 0 Then PicName = PicName & ".jpg"
　　　 'ファイルの有無
　　　 If Dir(PICPATH & PicName) = "" Then
　　　　　MsgBox PicName & " は、見つかりません。"
　　　　　Exit Sub
　　　　End If
　　　　With ActiveSheet.Pictures.Insert(PICPATH & PicName)
　　　　　　.Top = Cells(i, 6).Top
　　　　　　.Left = Cells(i, 6).Left
　　　　　　'ファイル名を封入
　　　　　　.ShapeRange.AlternativeText = PicName
　　　　End With
　　Else
　　　　ClearPIC Cells(i, 6)
　　End If
　　Range(arADD).ClearContents
　　Application.EnableEvents = False
　　For Each c In Range(arADD)
　　　　If IsPIC(c) = False Then
　　　　　　c.Value = "画像登録がありません."
　　　　End If
　　Next c
　　Application.EnableEvents = True
　　Application.ScreenUpdating = True
End Sub
'
Private Function IsPIC(ByVal rng As Range)
'画像がセルにあるか判定する関数プロシージャ
Dim pic As Picture
Dim flg As Boolean
　flg = False
　For Each pic In ActiveSheet.Pictures
　　With rng
　　　If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
　　　　flg = True: Exit For
　　　End If
　　End With
　Next pic
　 IsPIC = flg
End Function
'
Private Function ClearPIC(ByVal rng As Range)
''画像を削除する関数プロシージャ
　　Dim pic As Picture
　　For Each pic In ActiveSheet.Pictures
　　　　With rng
　　　　　　If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
　　　　　　　　pic.Delete
　　　　　　End If
　　　　End With
　　Next pic
End Function

変更要点は部分は、順不同でよいので、思いつくまま箇条書きにして結構です。
ブロックごとに修正しますので、これ以上は、関数プロシージャか、イベント本体を分割してアップします。ただし、繰り返しで恐縮しますが、コメントアウトで解説するのは、コメントアウトもコードの一部ですので、後々、やりにくくなってしまいます。これは、謹んでお断りします。

お礼

大変、大変ありがとうございました。
私のイメージした動きになりました。あとは本を見ながら、加工アレンジしてみます。

正直、ここまで親切、丁寧にタダで教えて頂ける方がいらっしゃるとは思いませんでした。
今、私の会社で取引しているベンダーさんなら、3人日の請求はされていたような
内容と思います。（^^;

本当に心より感謝いたします。ありがとうございました。

回答No.2

Wendy02

こんにちは。

#1さんの言い方とは違いますが、掲示板は、あくまでも、質問している方のお手伝いするスタイルになっています。[丸投げ]という言葉が、どういうものか、また、ここのカテゴリの削除対象の規約にあるか分かりませんが、

しかし、質問が理路整然となっていれば、文章だけで、回答者が何も言わないでも、質問者に答えることは可能なのですが、今回のご質問では、不足した部分が多いのです。また、それ以上に、ご質問者さんが想像するよりも、遥かに難しい内容だからということもあるのですが。

それは、画像がセルの上に存在するかどうかは、画像の全部を当たらなければ判定できないのです。そういう判定のコードをイベントの中に置くというのは、あまり合理的なコードではありません。

>できれば、勉強の為に’コメント説明付のご回答をお願いします。

以下は、分からないところがあればお教えできますが、予め解説をいれるのはお断りします。理由は、ひとつは、回答は、教えるためではなく、あくまでも、自分のために書いているのですが、もうひとつは、必要以上のコメントを入れるというのは、自分のコーディング・スタイルを壊すことになるからです。コメントもひとつのコードの中にあるものです。あるレベルに達している人は、それなりに、自分のコーディング・スタイルを持っているものなのです。

>入力セルとは、何を入れるのでしょうか？
>次に、画像は一定のものですか？
>画像が挿入される、という判定を画像でするのでしょうか？

この部分がわかりませんので、こちらで、勝手に考えさせていただきました。なお、バージョンに依存する部分があるような気がします。今回は、Ver.2003 で開発しました。

'シートモジュール (シートタブから、コードの表示で貼り付ける)
'-----------------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Long
　　Dim pic As Picture
　　Dim arAD As Variant
　　Dim c As Variant
　　'画像の場所
　　Const PICNAME As String = "D:\My Pictures\goo.gif"
　　'挿入セルの場所
　　Const arADD As String = "F2,F9,F16,F23,F30,F37,F44,F51"

　　arAD = Split(arADD, ",")

　　If Target.Count > 1 Then Exit Sub
　　If Intersect(Target, Range("B3:B10")) Is Nothing Then Exit Sub
　　i = (Target.Row - 3) * 7 + 2

　　Application.ScreenUpdating = False
　　If Target.Value <> "" Then
　　　　With ActiveSheet.Pictures.Insert(PICNAME)
　　　　　　.Top = Cells(i, 6).Top
　　　　　　.Left = Cells(i, 6).Left
　　　　End With
　　Else
　　　　ClearPIC Cells(i, 6)
　　End If
　　Range(arADD).ClearContents
　　Application.EnableEvents = False
　　For Each c In Range(arADD)
　　　　If IsPIC(c) = False Then
　　　　　　c.Value = "画像登録がありません."
　　　　End If
　　Next c
　　Application.EnableEvents = True
　　Application.ScreenUpdating = True
End Sub
Private Function IsPIC(ByVal rng As Range)
'画像がセルにあるか判定する関数
Dim pic As Picture
Dim flg As Boolean
　flg = False
　For Each pic In ActiveSheet.Pictures
　　With rng
　　　If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
　　　　flg = True: Exit For
　　　End If
　　End With
　Next pic
　 IsPIC = flg
End Function
Private Function ClearPIC(ByVal rng As Range)
'画像を削除する関数プロシージャ
　　Dim pic As Picture
　　For Each pic In ActiveSheet.Pictures
　　　　With rng
　　　　　　If Not Intersect(pic.TopLeftCell, rng) Is Nothing = True Then
　　　　　　　　pic.Delete
　　　　　　End If
　　　　End With
　　Next pic
End Function

お礼

大変ご丁寧な説明ありがとうございました。
VBAにチャレンジしたばかりで、質問内容もチンプンカンプンになってしまい、
申し訳ございません。やはり、多くの変数宣言が必要なのですね。
私には、到底たどり着けないコードでした。
補足として、セルへの入力内容は、画像のファイル名を入力します。
>入力セルとは、何を入れるのでしょうか？
　セルへの入力内容は、画像のファイル名を入力します
>次に、画像は一定のものですか？
　一定のもので、"D:\写真\"というフォルダに複数の画像”・・・・.jpg"が入って　います。
>画像が挿入される、という判定を画像でするのでしょうか？
　判定は、入力セルの値と画像のファイル名の合致でおこないます。

画像の判定で更に変数が必要でしょうか。
ずうずうしい注文で、申し訳ありませんが、お時間の許す限りでご指導願います。

質問方法もやさしくお教えいただき感謝いたします。

回答No.1

imogasi

質問文を工夫すること。
B3：B10の１つのセルに画像ファイル名を入力すると、シートの対応するセルの位置にその画像を表示したい。
質問が丸投げ（規約違反）になっている。その上回答者に注文まで着いている。
ーー
こんなの挿入ー図ーファイルからのマクロの記録をとれば骨格は判る。質問の処理のためにコードのどこを変えればよいか考えること。
マクロの記録ぐらいとって勉強しましたか。
（１）シートのChangeイベントで処理のコードを囲む
（２）入力セルと画像位置の対応のセルの割り出しの一方法（参考）
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Row >= 3 And Target.Row <= 10 Then
MsgBox Cells((Target.Row - 3) * 7 + 2, "F").Address
Else
MsgBox "範囲外"
End If
End Sub
をテストとしてやってみて、納得のこと。
（３）GOOGLEで
「エクセル　画像　挿入　VBA」で照会すればコード例もたくさん出る
事項だ。
Google照会などWEB照会して、勉強しましたか。
したのなら、質問が細かい点になるはず。

補足

ご回答ありがとうございました。
申し訳ありません。確かに質問文が不足していました。
しかも、B3:B10というのも間違えです。
B3入力時は、F2へ画像挿入　B4入力時は、F9へ画像挿入といった形にしたいのです。
御指導宜しくお願い致します。