マクロを使って画像を貼り付け

質問

VLOOKUPで画像を貼り付けしようと検索してましたが
自分のやりたいことをしようとすると、どうもマクロで設定したほうが
いいとわかりましたが、なかなか自分のイメージに近い参考URLがなく
ここに質問します。

まず、自分のやりたいイメージですが・・・
同じフォルダー内に画像を貼り付けしたいエクセルと画像フォルダーを一緒に置きます。

候補(1)エクセルの指定した場所に（9か所）一気に画像フォルダーから貼り付け。
候補(2)VLOOKUPみたいに数字を入力したら指定したセルに画像を貼り付け。

上記のことが可能でしょうか？
もしくは、近い操作ができるのでしょうか？

以上、わかるかたのご教授お願いします。
尚、上から目線の回答はやめてもらいたいです。

回答No.5

keithin · ベストアンサー

だいたいこんな具合ですね。

手順：
シート名タブを右クリックしてコードの表示を選ぶ
既存のコードを必ず全て消去する
下記をコピー貼り付ける

private sub Worksheet_Change(byval Target as excel.range)
　dim myPath as string
　dim myFile as string
　dim i as long
　dim a as variant

’準備
　if target.count > 1 then exit sub
　if application.intersect(target, range("Y1:Y9")) is nothing then exit sub
　if target = "" then exit sub
　if not isnumeric(target) then exit sub
　mypath = thisworkbook.path & "\"
　a = array("C7","I7","O7","C25","I25","O25","C43","I43","O43")

’画像の拾い上げ
　myfile = dir(mypath & "*.jpg")
　for i = 2 to target
　　myfile = dir()
　　if myfile = "" then
　　　msgbox "OUT OF RANGE"
　　　exit sub
　　end if
　next i

’画像の表示
　on error resume next
　activesheet.shapes("myPict_" & target.address).delete
　on error goto 0

　with activesheet.pictures.insert(mypath & myfile)
　　.top = range(a(target.row-1)).top
　　.left = range(a(target.row-1)).left
　　.name = "myPict_" & target.address
　end with
end sub

Ｙ１からＹ９に数字を記入する。

お礼

keithin様。
大変助かりました(T_T)
イメージ通りで本当に助かりました！
いろいろご丁寧にありがとうございました。

回答No.4

keithin

ん？　お願いしますから，ヒトの説明をちゃんと聞いてくださいね？

再掲：
＞丸投げでマクロを作って欲しい時は，こんな具合の説明が必要です：
＞指定のＣ１２セルに数字を記入すると，指定のＥ１２セルに画像を貼り付ける。

と，こういう具合に情報が必要ですとお話ししてますよね。

追加ご質問：
＞E12に貼り付けるのを指定したセルに飼える場合はどこの記述を変更すればいいかわかりません

どこのセルに変えたいのですか？　どうしたいのですか？
ご自分でマクロを修正できない事が判明したのですから，せめて回答者の投げかけには答えるようにしてください。
９パターンも一緒です。どこに数字を記入し，どこに画像を貼りたいのですか？
あんまり無茶な要求が後出しで出てくるご相談も少なくありません。マクロを最初からまた作り直さなきゃならないような二度手間三度手間になることも，「非常に多く」見かけます。

＞教えて頂いた記述を９パターン書き込めば大丈夫でしょうか？

これはまぁ今は判らなくても全然構いません（もちろん怒ったりとかしませんよ）けど，それじゃ全く全然ダメです。
たとえばこんな具合にします。

変更前：Ｃ１２セルに数字を記入する
if application.intersect(target, range("C12")) is nothing then exit sub

変更後：Ｃ１２，Ｃ２４，Ｃ３６…セルに記入する
if application.intersect(target, range("C12,C24,C36,C48,C60,C72,C84,C96")) is nothing then exit sub

＃あんまり言いたくありませんが，やさしく教えろと要求するのはまぁかまいません（やさしくおつきあいしてくださる回答者さんもいます）けど，せめてそれなりにキチンとコミュニケーションをしてくださいね？

補足

keithin様。
いろいろ申し訳ございません。
こちらの言葉足らずを知識不足でご迷惑をおかけしております。
数字を入力するセルはY1～Y9
写真を貼るセルはC7,I7,O7,C25,I25,O25,C43,I43,O43
数字を入力して写真を貼る順番は下記になります。
Y1→C7,Y2→I7,Y3→O7,Y4→C25,Y5→I25,Y6→O25,Y7→C43,Y8→I43,Y9→O43
以上になります。
申し訳ございませんが宜しくお願いします。

回答No.3

keithin

ふむ。。まぁ，マクロを使うならどうと言うことのない作業なのは確かですね。
ただ，マクロを使いたいなら「一体何をしたいのか」もっとキチンと説明が必要なんですが，だいぶ不十分なご相談です。
勿論，教わった内容を元にご自分でやりたいように応用できれば全然ＯＫなんですけどね。

＞VLOOKUPみたいに数字を入力したら指定したセルに画像を貼り付け。

丸投げでマクロを作って欲しい時は，こんな具合の説明が必要です：
　指定のＣ１２セルに数字を記入すると，指定のＥ１２セルに画像を貼り付ける。

準備：
ブックを画像のフォルダに保存する
ブックを開く
シートを開く
シート名タブを右クリックしてコードの表示を選ぶ
現れたシートに下記をコピー貼り付ける

private sub worksheet_change(byval Target as excel.range)
　dim myPath as string
　dim myFile as string
　dim i as long

’準備
　if target.count > 1 then exit sub
　if application.intersect(target, range("C12")) is nothing then exit sub
　if target = "" then exit sub
　if not isnumeric(target) then exit sub
　mypath = thisworkbook.path & "\"

’画像の拾い上げ
　myfile = dir(mypath & "*.jpg")
　for i = 2 to target
　　myfile = dir()
　　if myfile = "" then
　　　msgbox "OUT OF RANGE"
　　　exit sub
　　end if
　next i

’画像の表示
　on error resume next
　activesheet.shapes("myPict_" & target.address).delete
　on error goto 0

　with activesheet.pictures.insert(mypath & myfile)
　　.top = target.offset(0,2).top
　　.left = target.offset(0,2).left
　　.name = "myPict_" & target.address
　end with
end sub

ファイルメニューから終了してエクセルに戻る
指定のＣ１２セルに数字を記入すると，Ｅ１２セルに画像を表示する。

補足

keithin様。
教えて頂いた記述を試してみましたが自分のイメージにほほピッタリです。
C12に画像ファイルの番号を入力するのを変更する場所はわかったのですが
E12に貼り付けるのを指定したセルに飼える場合はどこの記述を変更すればいいかわかりません。
お手数ですが教えて頂けると助かります。
シートに9枚の画像を貼り付けたいのでその場合は教えて頂いた記述を９パターン書き込めば大丈夫でしょうか？

回答No.2

akina_line

こんにちは。

　>セルに貼り付けるときですが場所を指定できればと思っております。
　9個の画像を別々に場所指定するのですか？

　それとも1個の画像の場所を指定したら残り8個は自動的に位置が決まるのでしょうか。

　後者であれば、私のマクロと似ています。私のマクロはアクティブセルの位置を基準に1個目の画像を貼り、2個目以降は一つ右のセルに貼っています。
　参考になるか分かりませんが、リストの一部を貼っておきます。

では。
---------------------------------------------
'フォルダ・パス(Dname)の切り出し
Dname = Fname.lpstrFile
stat = Len("C:\") + 1
While stat > 0
stat = InStr(stat + 1, Dname, "\")
'MsgBox "Dname:" & Left(Dname, stat) & "; stat:" & CStr(stat)
If stat <> 0 Then
Old_stat = stat
End If
Wend
'MsgBox "Dname:" & Dname & "; Old_stat:" & CStr(Old_stat)
'アクティブセルの行、列を調べる
C = ActiveCell.Column
r = ActiveCell.Row
'MsgBox Str(c) + "列" + Str(r) + "行 F=" + Gname
Cells(r + 1, C).Activate
'フォルダ中のファイル名(Gname)取得
Gname = Dir(Left(Dname, Old_stat) & "*." & Mid(Dname, InStr(Old_stat, Dname, ".") + 1, 3))
'画像を挿入する
ActiveSheet.Pictures.Insert(Gname).Select
'セル(r,c)をアクティブにする
Cells(r, C).Value = Gname
C = C + 1
Cells(r + 1, C).Activate

While Not Gname = ""
Gname = Dir()
If Gname <> "" Then
'画像を挿入する
ActiveSheet.Pictures.Insert(Gname).Select
'Row = ActiveSheetActiveSheet.ActiveCell.Row
'ActiveSheet.ActiveCell.Row.Count = Row + 1
'MsgBox "アクティブセルは" + Str(c) + "列" + Str(r) + "行"
'あるセルをアクティブセルにするには、activateメソッドを使います。
'If r <= 5 Then
' MsgBox Str(c) + "列" + Str(r) + "行 F=" + Gname
'End If
'セル(c,r)をアクティブにする
Cells(r, C).Value = Gname
C = C + 1
Cells(r + 1, C).Activate
End If
Wend

回答No.1

akina_line

こんにちは。

　私はExcelで画像一覧を作成しています。
　選択したファイルの入っているフォルダから、その中に入っている全ファイル(拡張子は1種類)を横に(1セルに一枚)貼り付けています。

　こういう事をしたいのですか？

もう少し具体的なイメージを書いてみてください。

補足

回答ありがとうございます。
拡張子はjpgで考えております。
セルに貼り付けるときですが場所を指定できればと思っております。