エクセルのセルに指定画像(.jpg)を自動で貼り付けたいです。

初めまして。本当にド素人の質問で恐縮です。どなたかズバリ、やさしく教えていただけると助かります。
エクセル2010または2013 で、Book1、sheet1のC列に、デジカメ画像のファイル名(.jpgは除く)をテキストで記録してあります。
このファイル名の記録は連番であったり、抜けや順番が違うところ、70以上あります。
(ファイル名は、DSC03046、DSC03050、DSC03048・・・の様にズラッとC列に縦に記録しています。)
デジカメ画像は、C:\Users\mit\Desktop\写真のフォルダに格納してあります。

ご教示いただきたいことは、C列のデジカメ画像のファイル名を記録しているセルに、
写真フォルダのデジカメ画像(.jpg)を一気に貼り付けられるマクロ(プログラム)をズバリ教えていただきたいというものです。写真はセルに合わせる必要もなく、まずはそのままセルに貼れれば良いです。
ネットで似た質問のベストアンサーやプログラムをいろいろ試して、試行錯誤、解読も出来ず、困ってしまい質問をさせていただきました。
何卒、ご教示の程、宜しくお願い致します。

No.3 回答者： komugi3333 回答日時： 2019/07/16 01:56

すみません。

N02です。

ActiveSheet.Pictures.Insert(v_PicFulPath).Select

は

o_WS_01.Pictures.Insert(v_PicFulPath).Select

の書き間違いでした。すみません。

No.2 回答者： komugi3333 回答日時： 2019/07/16 01:49

例えばこんな感じとか・・・？

※私も初心者なので、細かいこと聞かれてもわかりませんので、これ以上のことはわかりません。

Sub PicImp_n_Resize01()

　Dim o_WS_01　　 As Worksheet
　Dim o_Cel_01　　As Range
　Dim o_Rngs_01　 As Range
　Dim l_RowHgt　　As Long
　Dim s_Colmn_01　 As String
　Dim v_PicFulPath　As Variant

　
　On Error Resume Next
　'もし入力されたフルパスの画像ファイルが、存在しないか、
　'パスやファイル名に誤りがあるとエラーになるのですが、
　'もしそうなっても最後のフルパスまで処理を続ける。
　'（※いい加減なエラー処理なので改善が必要。）
　
　
'　Application.ScreenUpdating = False
'　'画面の描画を止める
　
　

　'●各種設定。
　
　Set o_WS_01 = ActiveWorkbook.Worksheets("Sheet1")
　'目的のシートをオブジェクト変数に代入（シートに短い仮名をつける感じ。）
　
　
　Set o_Rngs_01 = o_WS_01.Range("D1:D4")
　'For Eachのループによって画像ファイルをセットするセル範囲を指定。
　'（一番上の行が列名になっているなら、"D2:D4" みたいな感じに変える。）
　　
　
　l_RowHgt = 70
　'行の高さと画像ファイルの高さをこの高さに設定。
　
　
　s_Colmn_01 = "C"
　'画像ファイルのフルパスの入力されている列を指定。
　



　
　'●メインループ処理
　'指定したフルパスの画像ファイルを、各セルの位置に挿入して大きさを合わせる。
　
　For Each o_Cel_01 In o_Rngs_01
　'指定したセル範囲のすべてのセルに以下の処理。

　　o_Cel_01.Select
　　'まずセルを選択。これをすることで、画像ファイルの挿入位置を決定。
　　'選択したセルの位置に、画像ファイルが挿入されます。
　　'（また、For Eachのループによって、自動的に一番上のセルから順番に選択されます。）
　　

　　Rows(o_Cel_01.Row).RowHeight = l_RowHgt
　　'選択したセルの行の高さを、前段階で設定した高さに変更。
　　
　　
　　v_PicFulPath = o_WS_01.Range(s_Colmn_01 & o_Cel_01.Row)
　　'画像ファイルのフルパスの取得（C列より）
　　
　　
　　ActiveSheet.Pictures.Insert(v_PicFulPath).Select
　　'「C列に入力されたフルパス」の画像ファイルを挿入してそれを選択。
　　

　　Selection.ShapeRange.ScaleHeight l_RowHgt / _
　　　Selection.ShapeRange.Height, _
　　　msoFalse, _
　　　msoScaleFromTopLeft
　　'挿入・選択した画像ファイルを、その行の高さに合わせる。
　　'※縦横比が保持されるので、自動的に横も合わさります。
　　
　Next o_Cel_01




　'●後始末。

'　Application.ScreenUpdating = True
　
　MsgBox "完了。　　※存在しないか、パスやファイル名に誤りがある画像は抜けています。"
　　
End Sub

No.1 回答者： 銀鱗 回答日時： 2019/07/15 14:59

まったく同じものを探しても、見つからない事の方が多いですよ。

そういう時は、見つけたマクロが何をしているのかを読み取れなければ無駄な時間を使うだけです。

まずはどんな手順で作業を行うのかを明確にしましょう。
その手段の一つに一つずつ順番に記述したケースを考える方法があります。
そうやって作ったマクロを修正して
　「繰り返し処理」
をさせることで問題を解決できることがあります。
というか、このケースではそれで十分だろうと思います。

・・・
一例をあげると
一つずつ順番に記述するマクロは

Sub Macro1()

　　Range("C1").Select
　　ActiveSheet.Pictures.Insert( _
　　　"C:\Users\mit\Desktop\写真のフォルダ\DSC03046.jpg").Select

　　Range("C2").Select
　　ActiveSheet.Pictures.Insert( _
　　　"C:\Users\mit\Desktop\写真のフォルダ\DSC03050.jpg").Select

End Sub

などと解釈されるような書き方になります。
ここから繰り返しの作業をさせるための共通部分を考える。

Sub Macro1()

　　Range("●●").Select
　　ActiveSheet.Pictures.Insert( _
　　　"C:\Users\mit\Desktop\写真のフォルダ\●●●●.jpg").Select

　　Range("●●").Select
　　ActiveSheet.Pictures.Insert( _
　　　"C:\Users\mit\Desktop\写真のフォルダ\●●●●.jpg").Select

End Sub

こんな感じでしょう。
ならば、

Sub Macro1()

　　Range("●●").Select
　　ActiveSheet.Pictures.Insert( _
　　　"C:\Users\mit\Desktop\写真のフォルダ\●●●●.jpg").Select

End Sub

だけでいい。
あとは、●●と●●●●の部分に必要な値が入るように工夫するだけ。
●●で示されるC列のセルを選択し、そこの値を読み取って●●●●に当てはめてやれば良いということ。
このくらいのやり方は調べられますよね。

あとは「繰り返し」作業を行わせるだけになります。
必要なだけ●●を読み取り続ければいい。
　・上から順番に値を読み取り、値が無くなったら繰り返し処理を終わらせるか、
　・指定した行まで繰り返し処理を行い、●●●●の記述が無いセルには貼り付けないようにするか、
　・すべての行に対して繰り返し処理を行い、●●●●の記述が無いセルには貼り付けないようにするか、
は質問者さんの考え方次第です。


・・・余談・・・
ごめん。
ここは作業依頼をする場所ではないのです。
疑問を解決するための場所なんです。
質問者さんが分からないところを分かるようにするための場所と言ったほうが良いでしょう。

たしかにそのものずばりのマクロを示せば目の前の問題は解決しますが、疑問は先送りにされるだけで、
似たような問題が出たときに自力での解決はできません。
それって本当に問題が解決したと言えるのでしょうか。

そんなわけで上記の説明の中で具体的に分からない点を補足などで質問すると良いと思います。
自力でマクロを作ることにより分からない点を明確にし、その分からない点を質問することで不足している知識を補うことができます。

がんばってください。

この回答へのお礼

ありがとうございます。
余談。おっしゃる通りなのですが、セルの画像ファイル名と同じ画像を、画像フォルダから探して読み込み、セルに表示させるという繰り返しのループが分からず。。

お礼日時：2019/07/15 17:35