[[20161205144439]]　『セルにファイル名入力し、その画像を貼り付ける』（MSO）　ページの最後に飛ぶ

『セルにファイル名入力し、その画像を貼り付ける』（MSO）

初めて質問致します。
VBA初心者につき、どなたかご指導頂ければと思います。

特定のセル（例えば"A1"）へファイル名を入力し画像を貼り付ける方法を探していたら、以下のマクロを見つけました。
これにより希望に近いところまで行くのですが、実際に使用するにはもう少し修正が必要となります。

【修正したい内容】
１．90度回転させる
　⇒画像が回転した状態で貼り付けするようにしたい（必ず90度回転するように）
２．さらに貼り付け先のセルの大きさに拡大する
　⇒貼り付け先のセルは、あらかじめセルを結合し大きくしています
　⇒縦横比は変化しないようにしたい・・・結合セルの縦もしくは横の最大にあわせる

【実際の問題点】
３．A1セルには計算式が入っており、計算結果が変化しても画像が更新されない
（A1セル選択後に「F2」→「Enter」の操作をすれば画像は更新する）
　⇒計算結果により画像が更新するようにしたい

１～３の要望を満たすマクロを教えて下さい。
よろしくお願いします。

↓↓↓↓以下、見つけたマクロです↓↓↓

A1セルにファイル名（拡張子なし）を入力したらD3セルに指定した画像を貼り付けるものです。

試しに新しいブックを開き「シート名右クリック」→「コードの表示」で開く画面に以下のマクロを貼り付けてください。マクロ２行目～５行目はご自身の環境に合わせて修正が必要です。

Private Sub Worksheet_Change(ByVal Target As Range)
Const trgR As String = "A1" '地図通し番号を入力するセル
Const insR As String = "D3" '挿入画像の左上のセル
Const path As String = "Z:\" 'ファイルの格納フォルダ
Const pic　As String = ".jpg"　'「.(半角)」＋ファイルの拡張子"
Dim shp As Shape
Dim buf As String
　　If Target.Address(0, 0) = trgR Then
　　　　For Each shp In ActiveSheet.Shapes　'既に表示されている画像を削除する処理
　　　　　　If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
　　　　　　　　　　　　shp.BottomRightCell)) Is Nothing Then
　　　　　　　　shp.Delete
　　　　　　End If
　　　　Next
　　　　Range(insR).Select
　　　　buf = Dir(path & Target.Value & pic)
　　　　If buf <> "" Then　'入力したファイル名があるかチェック
　　　　　　ActiveSheet.Pictures.Insert (path & Target.Value & pic)
　　　　Else
　　　　　　MsgBox "指定したファイルがありません"
　　　　End If
　　End If
　　Target.Offset(1, 0).Select
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 3について。
 もし、式が他のセルを参照しているのであれば式が入力されているセルではなくその式が参照しているセルが変化したかの
 チェックをしてはどうか。
（ねむねむ） 2016/12/05(月) 15:40

ねむねむ様
早速ご指導頂き、ありがとうございます。
A1セルには、vlookupの式でファイル名が表示されるようになっています。
別シートに　NO、ファイル名の一覧があり、D5セルに１，２，３，４，・・・・・・と入れるとA1が変化致します。

D5セルに１，２，３，４と入力した場合に画像も合わせて更新したいと考えております。

（MSO） 2016/12/05(月) 16:03

 今現在、
 >If Target.Address(0, 0) = trgR Then 
 で、入力したセルがtrgRの時に処理を行っている。

 そのtrgRは
 >Const trgR As String = "A1" '地図通し番号を入力するセル 
 でA1と設定されている。

 A1セルがD5セルを参照して変化するのであればこれを
 >Const trgR As String = "D5" '地図通し番号を入力するセル  
 で。

 あと、
 >buf = Dir(path & Target.Value & pic) 
 >    If buf <> "" Then　'入力したファイル名があるかチェック 
 >        ActiveSheet.Pictures.Insert (path & Target.Value & pic)
 の部分でファイル名を求めているがMSOさんの環境ではTarget(D5セル)とファイル名の
 入っているセル(A1セル)は異なるため、

 >buf = Dir(path & Range("A1").Value & pic) 
 >    If buf <> "" Then　'入力したファイル名があるかチェック 
 >        ActiveSheet.Pictures.Insert (path & Range("A1").Value & pic)
 としてみてくれ。

（ねむねむ） 2016/12/05(月) 16:18

A1セルが式のままでは変わりませんが、その式が見ている先で判定すれば良いのではないでしょうか。
でもって、回転するマクロはちょいと整形して、以下の感じで。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Const trgR As String = "A1" '地図通し番号を入力するセル
    Const insR As String = "D3" '挿入画像の左上のセル
    Const path As String = "Z:\" 'ファイルの格納フォルダ
    Const pic As String = ".jpg"   '「.(半角)」＋ファイルの拡張子"
    Dim shp As Shape
    Dim buf As String
    Dim M As Range

    If Target.Address(0, 0) = trgR Then
        buf = Dir(path & Target.Value & pic)
        If buf <> "" Then  '入力したファイル名があるかチェック
            For Each shp In ActiveSheet.Shapes  '既に表示されている画像を削除する処理
                If Not Intersect(Range(insR), Range(shp.TopLeftCell, _
                            shp.BottomRightCell)) Is Nothing Then
                    shp.Delete
                End If
            Next

            Set M = Range(insR).MergeArea
            With ActiveSheet.Pictures.Insert(path & Target.Value & pic)
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.IncrementRotation 90
                .Width = M.Height
                If M.Width < .Height Then
                    .Height = M.Width
                End If
                .Left = M.Left + (M.Width - .Width) / 2
                .Top = M.Top + (M.Height - .Height) / 2
            End With
        Else
            MsgBox "指定したファイルがありません"
        End If
    End If
 End Sub
（???） 2016/12/05(月) 16:34

 >>別シートに　NO、ファイル名の一覧があり、D5セルに１，２，３，４，・・・・・・と入れるとA1が変化致します。

 計算式の入ったセルの値変化は、皆さんいわれるように、Changeイベントの対象外です。
 ですから、ふつうは、その式が参照しているセルの変化をもって、式による値が変化したとみなして処理します。
 D5 というのが、同じシートの D5 であれば、

 Const trgR As String = "D5"

 としてやれば、とりあえずは　イベントプロシジャが動くはずです。

 とりあえず　と書きました。　セルへの入力は、該当のセルも含んだ、複数セル一括書きこみも可能です。
 そういったケースでは、Targetアドレスがそのセルにはなっていないので、空振りします。

 If Target.Address(0, 0) = trgR Then

 これを

 If Not Intersect(Target,Range(trgR)) Is Nothing Then

 こうしておかれることをおすすめします。

 ★厳密にいえば別シートの一覧が変更された場合も A1 の値はかわりますので
 　そちらのセル領域における変更も処理対象にすべきなんですが。
 　この場合は、現在のチェックと別シートのチェックあわせて、ThisWorkbookモジュールで
 　処理するのがスムーズだと思います。

（β） 2016/12/05(月) 16:49

元ソースコードは、以下のQAのzap35さん作のようですね。
http://oshiete.goo.ne.jp/qa/3749418.html

人のコードを利用する際は、URLや作者名を記述しておくのが礼儀ってもんです。
回答者は小さな妖精でもロボットでもないですから、誰が作ったか判らないけど、コードだけ頂く、とはならないように。
（出典を明らかにしておくことは、著作権上も良い事だと思いますよ）
（???） 2016/12/05(月) 17:12

ねむねむ様
???様

希望した通り、動作することに成功しました！！

???様から教えて頂いたマクロで回転および拡大が解決し
更に、その中の一部、「Target.Value」を
ねむねむ様から教えて頂いた「Range("A1").Value」に書き換える事で無事に仕上がりました！！

2ヶ月近く悩んでいたのが、この一瞬で解決してしまうなんて、、、
攻め方の発想を変えたり、知識の豊富さに脱帽です！

ほんとうに、ほんとうに助かりました！！！
ありがとうございましたm(_ _)m

β様

判りやすく教えて頂き、ありがとうございます。
計算式の入ったセルの値変化は、Changeイベントの対象外になるんですね・・・・。勉強になります！

マクロの記録から「A1セル選択→F2→Enter」を登録し、コレを使おうと四苦八苦してました。

また、このマクロの使い方としては、
”1”入力→プリントアウト、
"2"入力→プリントアウト・・・・

という使い方をしていますので、一括書き込みは現時点では必要ありませんが、
仕様変更したときに、空振りしたら、思い出してみたいと思います！

皆様、ご指導頂き、ありがとうございました。
（MSO） 2016/12/05(月) 17:16

???様

ご指摘頂き、ありがとうございます。
確かに元ソースコードは、QAのzap35さん作によるものです。

配慮に欠けておりました。

こういったエクセルの質問は初めて行いましたので、そのようなご指摘はありがたく受け取りたいと思います。
次回、機会があれば、きちんと明確にしたいと思います。
（MSO） 2016/12/05(月) 17:23

コメント返信：

[ 一覧(最新更新順) ]

[[20161205144439]] 『セルにファイル名入力し、その画像を貼り付ける』（MSO） ページの最後に飛ぶ

[[20161205144439]]　『セルにファイル名入力し、その画像を貼り付ける』（MSO）　ページの最後に飛ぶ