今だけ人気マンガ100円レンタル特集♪

はじめまして。

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

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

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

宜しくお願い致します。

A 回答 (2件)

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


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

問題の箇所
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 '貼り付けセル
    • good
    • 1
この回答へのお礼

助かりました

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

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

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

貼り付ける例が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イベントに他の処理などがある場合、適時エラー処理を行ってください。
    • good
    • 1

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

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング