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

Question

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

end-u · Accepted Answer

>現行の「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もよく勉強しないで恐縮ですが、
>ではメンテナンスの時に困りますから、よく勉強してくださいね。

end-u · Answer

可能性としてはフォルダ名や拡張子が違う事などが考えられます。
また、『入力しても』とありますが
入力後自動で実行されるわけではなく、
入力してリストアップした後に、マクロを実行しなければいけません。
（おわかりかと思いますが念の為）

それでは、拡張子込みでファイル名を書き出してテストしてみましょう。

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

こんな感じです。

end-u · Answer

こんにちは。
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もよく勉強しないで恐縮ですが、
ではメンテナンスの時に困りますから、よく勉強してくださいね。

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

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

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

こんにちは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング