VBAを使ったエクセルでの画像複数表示

VBA初心者です。エクセルで商品カタログを作るため、品番に紐付いた商品画像ファイルをエクセル上に読み込む方法は他の回答から分かったのですが（http://oshiete1.goo.ne.jp/qa2880877.html）、見る限り「1シート＝１商品」というものしか見つけられませんでした。同シート上に２つ以上の「品番⇒画像」という表示をするためのVBAはどのように組めばよろしいでしょうか？
VBAもよく勉強しないで恐縮ですが、どなたかご回答いただけますでしょうか？宜しくお願い致します。

No.3 ベストアンサー 回答者： end-u 回答日時： 2008/05/08 16:56

>現行の「A列入力⇒B列表示」の発展系で、「XXに入力⇒XXに表示」

>というように個別に指定することは可能なのでしょうか？
可能です。
>fn = .Cells(i, 1).Value
>Set r = .Cells(i, 2)
ここで使っているCellsプロパティは
Cells(行, 列)...で指定します。
この『列』である 1(A列) や 2(B列) を変更すれば良いです。
.Cells(i, "A").Value など文字列で指定する事もできます。

都度入力方式にしたいなら、変数を使って下記のようにします。
Sub try3()
　　Dim r　As Range　'表示セル用
　　Dim fd As String 'フォルダ用
　　Dim fn As String '画像ファイル名用
　　Dim x1 As String 'ファイル名列用
　　Dim x2 As String '出力先列用
　　Dim n　As Long　 '最下行用
　　Dim i　As Long　 'Loopカウンタ
　　
　　With Application
　　　　x1 = .InputBox("ファイル名の列入力" & vbLf & "ex) A", Type:=2)
　　　　If x1 = "False" Then Exit Sub
　　　　x2 = .InputBox("出力先の列入力" & vbLf & "ex) B", Type:=2)
　　　　If x2 = "False" Then Exit Sub
　　End With
　　If Len(x1) = 0 Or Len(x2) = 0 Then Exit Sub
　　fd = FDselect("画像フォルダ選択")
　　If Len(fd) = 0 Then Exit Sub
　　On Error GoTo errHndlr
　　With ActiveSheet
　　　　n = .Cells(.Rows.Count, x1).End(xlUp).Row
　　　　If n = 1 And Len(.Cells(1, x1).Value) = 0 Then Exit Sub
　　　　Application.ScreenUpdating = False
　　　　For i = 1 To n
　　　　　　fn = .Cells(i, x1).Value
　　　　　　If Len(fn) > 0 Then
　　　　　　　　Set r = .Cells(i, x2)
　　　　　　　　If Len(Dir(fd & fn)) > 0 Then
　　　　　　　　　　With .Pictures.Insert(fd & fn).ShapeRange
　　　　　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　　　　　.Left = r.Left
　　　　　　　　　　　　.Top = r.Top
　　　　　　　　　　　　.Height = r.Height
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
errHndlr:
　　Set r = Nothing
　　Application.ScreenUpdating = True
　　If Err.Number <> 0 Then MsgBox Err.Number & vbLf & Err.Description
End Sub

'FolderSelectFunction
Private Function FDselect(ByVal s As String) As String
　　Dim obj As Object
　　Dim ret As String

　　Set obj = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, s, 0)
　　If obj Is Nothing Then Exit Function
　　On Error Resume Next
　　ret = obj.self.Path & "\"
　　If Err.Number <> 0 Then
　　　　ret = obj.Items.Item.Path & "\"
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　Set obj = Nothing
　　FDselect = ret
End Function

ただ、最初に書いてますが
>>VBAもよく勉強しないで恐縮ですが、
>ではメンテナンスの時に困りますから、よく勉強してくださいね。

この回答へのお礼

ご回答ありがとうございます。
おんぶにだっこで恐縮です。VBA勉強します！

お礼日時：2008/05/09 09:14

No.2 回答者： end-u 回答日時： 2008/05/08 12:20

可能性としてはフォルダ名や拡張子が違う事などが考えられます。

また、『入力しても』とありますが
入力後自動で実行されるわけではなく、
入力してリストアップした後に、マクロを実行しなければいけません。
（おわかりかと思いますが念の為）

それでは、拡張子込みでファイル名を書き出してテストしてみましょう。

Sub test()
　　Dim r　As Range　'表示セル用
　　Dim fd As String 'フォルダ用
　　Dim fn As String '画像ファイル名用
　　Dim i　As Long　 '行カウントアップ用

　　fd = "D:\image\"
　　With ActiveSheet
　　　　.UsedRange.ClearContents
　　　　.Pictures.Delete
　　　　Application.ScreenUpdating = False
　　　　fn = Dir(fd & "*.jpg") '拡張子を変更する必要があれば変更のこと
　　　　Do Until Len(fn) = 0
　　　　　　i = i + 1
　　　　　　.Cells(i, 1).Value = fn
　　　　　　Set r = .Cells(i, 2)
　　　　　　With .Pictures.Insert(fd & fn).ShapeRange
　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　.Left = r.Left
　　　　　　　　.Top = r.Top
　　　　　　　　.Height = r.Height
　　　　　　End With
　　　　　　fn = Dir()
　　　　Loop
　　End With
　　Set r = Nothing
　　Application.ScreenUpdating = True
End Sub

上記はアクティブなシートをクリアして、A1セルから下へ
"D:\image\"フォルダ直下の拡張子jpgファイルの一覧を書き出します。
それと同時にB列に画像を読み込みます。
読み込みが成功したら、ファイル名を確認してみてください。

一応、前回のコードを拡張子込みでリストアップしたものに対応させるように変更すると

Sub try2()
　　Dim r As Range　 '表示セル用
　　Dim fd As String 'フォルダ用
　　Dim fn As String '画像ファイル名用
　　Dim n As Long　　'最下行用
　　Dim i As Long　　'Loopカウンタ

　　fd = "D:\image\"
　　With ActiveSheet
　　　　n = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　If n = 1 And Len(.Cells(1, 1).Value) = 0 Then Exit Sub
　　　　Application.ScreenUpdating = False
　　　　For i = 1 To n
　　　　　　fn = .Cells(i, 1).Value
　　　　　　If Len(fn) > 0 Then
　　　　　　　　Set r = .Cells(i, 2)
　　　　　　　　If Len(Dir(fd & fn)) > 0 Then
　　　　　　　　　　With .Pictures.Insert(fd & fn).ShapeRange
　　　　　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　　　　　.Left = r.Left
　　　　　　　　　　　　.Top = r.Top
　　　　　　　　　　　　.Height = r.Height
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　Set r = Nothing
　　Application.ScreenUpdating = True
End Sub

こんな感じです。

この回答へのお礼

早々のご回答ありがとうございます。
イメージ通り画像が出るようになりました！ありがとうございます。

また、お時間あるときに教えていただければありがたいのですが、
現行の「A列入力⇒B列表示」の発展系で、「XXに入力⇒XXに表示」
というように個別に指定することは可能なのでしょうか？
違うフォーマットのカタログも作る必要がありまして、その際に
非常に重宝しそうです。

お礼日時：2008/05/08 14:00

No.1 回答者： end-u 回答日時： 2008/05/08 01:57

こんにちは。

A1セルから下へ、画像ファイル名のC:\Users\Public\Pictures\Sample Pictures\xxx.jpg
などの xxx という、拡張子を除いた名前だけが入力されているとします。
そのA列をLoopして、隣のB列に、セルの高さに合わせて画像を配置します。
事前に、ファイル名を入力し、その行高を広げておいてください。
コード内でフォルダは固定させています。変更必要です。

Sub try()
　　Dim r As Range　 '表示セル用
　　Dim fd As String 'フォルダ用
　　Dim fn As String '画像ファイル名用
　　Dim n As Long　　'最下行用
　　Dim i As Long　　'Loopカウンタ

　　fd = "C:\Users\Public\Pictures\Sample Pictures\" '変更要
　　With ActiveSheet
　　　　n = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　If n = 1 And Len(.Cells(1, 1).Value) = 0 Then Exit Sub
　　　　Application.ScreenUpdating = False
　　　　For i = 1 To n
　　　　　　fn = .Cells(i, 1).Value & ".jpg"
　　　　　　If Len(fn) > 4 Then
　　　　　　　　Set r = .Cells(i, 2)
　　　　　　　　If Len(Dir(fd & fn)) > 0 Then
　　　　　　　　　　With .Pictures.Insert(fd & fn).ShapeRange
　　　　　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　　　　　.Left = r.Left
　　　　　　　　　　　　.Top = r.Top
　　　　　　　　　　　　.Height = r.Height
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　End With
　　Set r = Nothing
　　Application.ScreenUpdating = True
End Sub

>VBAもよく勉強しないで恐縮ですが、
ではメンテナンスの時に困りますから、よく勉強してくださいね。

この回答へのお礼

早速ご回答ありがとうございました。
非常に分かり易く御説明いただいており、手順も明確なのですが、
入力しても画像が表示されません。。

画像フォルダはローカルディスクD直下の「image」フォルダに
入れているため、
fd = "D:\image\"
と変更はしました。
A列には「image」フォルダ内に入っているJPEGデータファイル
の拡張子を除いたファイル名を入力しました。

何か間違えてますでしょうか？

お礼日時：2008/05/08 10:24