Excel セルに入力した画像名からフォルダの画像を自動表示させたい

はじめまして。

Excelで、セルに画像名を入力したら指定した場所にフォルダの画像を自動で表示できるようにしたいです
(A1に「空」と入力したらフォルダ内にある「空」という名前の写真が表示される)。

https://oshiete.goo.ne.jp/qa/3749418.html
こちらの回答者様のコードを参考にし自動表示させるところまではいったのですが、わたしの知識では画像が1枚しか表示されず(セルA1しか指定していないのでA1に入力した画像しか表示されません)、また、画像の大きさも指定出来ていないのでサイズが大きいままドンと表示されてしまいます。

A1に入力した画像はB1に、A3に入力した画像はB3に、、というように場所の指定とサイズの指定をしたいのですが調べても調べても解決せず、お力を貸して頂けないでしょうか。
(同じような内容に対する回答のコードも使用させて頂きましたが解決に至りませんでした。)

宜しくお願い致します。

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2020/06/02 04:18

投稿して気づきましたが、先のもの流れでプロセスを書き換えましたが、問題を見つけました。

私自身書いている通り　実行されたセルの検証　＞　画像の存在検証　＞　指定場所の既存画像を削除　＞　指定画像を貼り付け　＞　サイズ調整　＞　次の準備　
であるべきで、掲示されたコードは、検証前に画像が消去されています。（新規画像が無くても既存画像が削除されます）
下記の様に変更するべきなので、訂正します。

問題の箇所
If Target.Address(0, 0) = "A1" Or Target.Address(0, 0) = "A3" Then '実行されるセル
　　 For Each shp In ActiveSheet.Shapes　 '表示画像を削除
　　　　If Not Intersect(Target.Offset(, 1), Range(shp.TopLeftCell, _
　　　　　　　　　　　　　　　　　　 shp.BottomRightCell)) Is Nothing Then
　　　　　 shp.Delete
　　　　End If
　　 Next
　　 buf = Dir(path & Target.Value & pic) '画像の存在検証
　　 If buf <> "" Then

修正後

If Target.Address(0, 0) = "A1" Or Target.Address(0, 0) = "A3" Then '実行されるセル
　　 buf = Dir(path & Target.Value & pic)　'画像の存在検証
　　 If buf <> "" Then 　　　　　　　　　 '存在していれば
　　 For Each shp In ActiveSheet.Shapes　 '表示画像を削除
　　　　If Not Intersect(Target.Offset(, 1), Range(shp.TopLeftCell, _
　　　　　　　　　　　　　　　　　　 shp.BottomRightCell)) Is Nothing Then
　　　　　 shp.Delete
　　　　End If
　　 Next
　　Target.Offset(, 1).Select '貼り付けセル

この回答へのお礼

質問内容に曖昧な部分があり大変申し訳ありませんでした。
ただ、Qchan1962様に教えて頂いたコード入力したら私が求めていた通りの表示になりました！本当にすごいです…
丁寧なご回答本当にありがとうございました！
とても助かりました。。

教えて頂いたコードを活用し、表を作成していきたいと思います。その中でまた分からないことがあったら質問させて頂きますので宜しくお願い致します。

お礼日時：2020/06/02 12:18

No.1 回答者： Qchan1962 回答日時： 2020/06/02 04:04

貼り付ける例が2つ出ていますが、相対位置は分かりますが、どの位あるのか不明です。

また、Resizeを希望されているようですが、どのようなサイズにしたいのかも不明です。
しかし、ご自身で検証などを行っているようなので、そのあたりは、変更してください。

リンク先のものを検証されていると思いますので、構造的なところは変更せず下記に解る範囲のものを
サンプルとして挙げます。

Private Sub Worksheet_Change(ByVal Target As Range)
Const path As String = "C:\hoge\"　 'ファイルの格納フォルダ
Const pic As String = ".jpg"　 '「.(半角)」＋ファイルの拡張子"
Dim shp As Shape
Dim buf As String
　 If Target.Address(0, 0) = "A1" Or Target.Address(0, 0) = "A3" Then '実行されるセル
　　 For Each shp In ActiveSheet.Shapes　 '表示画像を削除
　　　　If Not Intersect(Target.Offset(, 1), Range(shp.TopLeftCell, _
　　　　　　　　　　　　　　　　　　 shp.BottomRightCell)) Is Nothing Then
　　　　　 shp.Delete
　　　　End If
　　 Next
　　 buf = Dir(path & Target.Value & pic)
　　 If buf <> "" Then
　　　　Target.Offset(, 1).Select '貼り付けセル
　　　　Set shp = ActiveSheet.Shapes.AddPicture( _
　　　　　　　 path & buf, _
　　　　　　　 msoFalse, msoTrue, Selection.Left, Selection.Top, -1, -1)

　 '　　　　ここで画像サイズ、セル内配置などを設定する
　 '　　　　上のmsoTrueをmsoFalseに設定すると縦横比を破棄します
　 '　　　　画像の縦横比を維持しているので片方で指定で良い
　 '　　　　shp.Height = 50 'resize
　　　　shp.Width = ActiveCell.Width
　 '　　　　shp.Height = ActiveCell.Height
　　　　
　　　　Target.Offset(2).Select
　　 Else
　　　　MsgBox "指定したファイルがありません"
　　 End If
　 End If
End Sub

改造と理解が必要なところ
If Target.Address(0, 0) = "A1" Or Target.Address(0, 0) = "A3" Then '実行されるセル
ここで、実行されるセルのChangeを分岐しています。（今回例はA1　A3　です。）
規則性や範囲などで設定したり、Intersectなどで設定する事が多いと思います。

Target.Offset(, 1)　実行されたセルの1つ右隣

Shapes.AddPictureメソッドのパラメータ
Addpicture(FileName、 linktofile、 savewithdocument、 Left、 Top、 Width、 Height)

shp.Width = ActiveCell.Width　
セルに対してサイズ、位置などを合わせるテクニックなど
shp.Height = ActiveCel.Height
If shp.Width >ActiveCell.Width Then
shp.Width = ActiveCell.Width
End If

Worksheet_Changeで画像を取り込む場合の流れは、ほぼ同様の流れになると思います。
実行されたセルの検証　＞　画像の存在検証　＞　指定場所の既存画像を削除　＞　指定画像を貼り付け　＞　サイズ調整　＞　次の準備　


エラー処理は、ほぼされておらず、buf = Dir(path & Target.Value & pic)くらいです。
同じ、Worksheet_Changeイベントに他の処理などがある場合、適時エラー処理を行ってください。