マクロでセルに入れたファイル名の画像を隣のセルに読み込む

質問

こんにちは。宜しくお願いします。

マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業を行いたいのですが・・・。うまくいきません。どなたかご助言いただけると助かります。

＜内容＞
セル内には上から1位・2位と順位通りになっており、その順位に入っているセルのファイル名と一致している画像を隣のセルに読み込みたいと思っています。またファイル名と画像が一致しない場合は「No　Image」として1枚の画像を貼り付けることもしたいです。

　　　A(順位)　　B(名)　　　　C(画像)
---------------------------------------------
1　　　1位　　　test01　　　D:\画像\teet01.JPG
2　　　2位　　　test02　　　D:\画像\teet02.JPG
3　　　3位　　　test03　　　D:\画像\teet03.JPG
.
.
.
10　　10位　　　test10　　　D:\画像\teet10.JPG

＜問題点＞
・B2の「test01」から順に読み込んでもらいたいのにB1の「名」を読み込んでしまうためエラーが生じる。
・画像をセルの結合した分の大きさに合わせたいのだが、セル1個分のサイズに表示してしまうためうまく調節できない。

＜マクロ文＞
Private Sub CommandButton1_Click()

Dim i As Long
Dim myPic As Object
Dim myCell As Range

For i = 1 To Range("C" & ActiveSheet.Rows.Count).End(xlUp).Row
Set myCell = Range("C" & i)
Set myPic = ActiveSheet.Pictures.Insert("D:\画像\" & myCell.Value & ".JPG")
With myPic
.Width = Range("D2").Width
.Height = Range("D2").Height
End With
Set myPic = Nothing
Next i

End Sub

色々とネット等を見てはいるのですが・・・うまくいきませんでした。
どこをどのようにして代えればうまく動作するか分かる方いらっしゃいましたら教えていただきたいです。宜しくお願い致します。

回答No.2

end-u · ベストアンサー

倍率の変更もですが、それより Top 位置の調整が必要です。

Sub try_2()
　　Const n As Long = 2 'margin
　　Dim r As Range
　　Dim i As Long
　　Dim x As Double
　　Dim s As String

　　With ActiveSheet
　　　　For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 6
　　　　　　Set r = .Cells(i, 3).MergeArea
　　　　　　s = "D:\画像\" & .Cells(i, 2).Value & ".jpg"
　　　　　　If Dir(s) = "" Then
　　　　　　　　s = "D:\画像\noimage.jpg"
　　　　　　Else
　　　　　　　　Dir Application.Path
　　　　　　End If
　　　　　　'r.Item(1).Value = s
　　　　　　With .Pictures.Insert(s).ShapeRange
　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　x = Application.Min(r.Width / .Width, (r.Height - n) / .Height)
　　　　　　　　.Width = .Width * x
　　　　　　　　.Left = r.Left
　　　　　　　　.Top = r.Top + n / 2
　　　　　　End With
　　　　Next
　　End With

　　Set r = Nothing
End Sub

こんな感じで n の数値を変更して調整してください。
必要であればWidthとLeftも同じように。

中央に配置したい場合は以下に変更。
.Left = r.Left + (r.Width - .Width) / 2
.Top = r.Top + (r.Height - .Height) / 2

お礼

end-uさん
おぉ！まさにこれを求めていました。ありがとうございます。
欲を言うと・・・。No　Imageの画像には非対応な感じでしたので
No　Image画像にも同様、枠内に収めたいのですが。マクロ文を追加
しないとダメでしょうか？それとももともとの画像サイズが大きいとか
ですかね？？

回答No.3

end-u

>No　Imageの画像には非対応な感じでしたので
>No　Image画像にも同様、枠内に収めたいのですが。
...はて？解りません。
他のjpgファイルはokなのに『No　Imageの画像』がNGなのですね。
ファイルの問題じゃないですか？
他のファイルで試したり、サイズ変更して作り直したりしてみれば良いんじゃないでしょうか。
後は、貴方の方で色々と工夫する事で対応できるのではないかと思います。
では、この辺で。がんばってください。

お礼

end-uさん
「No　Image」の方の画像サイズを変更したら直りました。
ご指摘ありがとうございます。
これで理想としていたことが完成しました。本当にありがとうございました。

回答No.1

end-u

とりあえず、最低限の修正なら
Private Sub CommandButton1_Click()
　　Dim i　　　As Long
　　Dim myPic　As Object
　　Dim myCell As Range

　　For i = 2 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row Step 6
　　　　Set myCell = Range("B" & i)
　　　　Set myPic = ActiveSheet.Pictures.Insert("D:\画像\" & myCell.Value & ".JPG")
　　　　With myPic
　　　　　　.Left = Range("C" & i).Left
　　　　　　.Top = Range("C" & i).Top
　　　　　　.Width = Range("C" & i).MergeArea.Width
　　　　　　.Height = Range("C" & i).MergeArea.Height
　　　　End With
　　　　Set myPic = Nothing
　　Next i
End Sub

縦横比固定の場合
Sub try()
　　Dim r As Range
　　Dim i As Long
　　Dim x As Double
　　Dim s As String

　　With ActiveSheet
　　　　For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row Step 6
　　　　　　Set r = .Cells(i, 3).MergeArea
　　　　　　s = "D:\画像\" & .Cells(i, 2).Value & ".jpg"
　　　　　　If Dir(s) = "" Then
　　　　　　　　s = "D:\画像\noimage.jpg"
　　　　　　Else
　　　　　　　　Dir Application.Path
　　　　　　End If
　　　　　　'r.Item(1).Value = s
　　　　　　With .Pictures.Insert(s).ShapeRange
　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　x = Application.Min(r.Width / .Width, r.Height / .Height)
　　　　　　　　If x < 1 Then .Width = .Width * x
　　　　　　　　.Left = r.Left
　　　　　　　　.Top = r.Top
　　　　　　End With
　　　　Next
　　End With

　　Set r = Nothing
End Sub

お礼

end-uさん
イメージ通りのものができました。ご回答ありがとうございます。
どこがどう反映されているか、なんとなく分かったような気がします。
ただ、Ｃ2に画像が入った場合に枠線の上に重なるように画像が貼り付けられてしまうので縦横比固定の箇所で倍率の変更が出きればと思うのですが・・・
そこだけ何か解決案があればお聞きしたいです。