ディレクトリ見直し君(R)の画像表示について

Question

お世話になっております。
ディレクトリ見直し君のシートですが、取扱商品が多いため、画像を1つずつ開く事が困難です。小さくても良いので画像1枚目のURLの画像を空いているセルにそれぞれ表示したいのですが、エクセルのバージョンが古いため、関数の「IMAGE」が使えません。
代用できる関数やマクロなどありましたら教えてもらえますでしょうか？

Accepted Answer

ECマスターズの山本です。

※改造したExcelを添付するため、
鍵付き投稿に変更しました。

お待たせいたしました。
デフォルトのディレクトリ見直し君のシートでは
C列の画像を表示した後に
別セルをクリックするとすべての
画像が削除される（表示を消す処理）が
内部的に実装されていたため、
専用処理としてカスタマイズしました。

基本的にURLの列のデータがおかしいと
マクロが停止する場合がありますので、
停止した場合には、停止箇所まで画像は
取得できている状態になりますので、
該当URLセルの状態を確認してください。

また、画像取得マクロでは、
いただいたデータ量ですと
実行完了まで数分程度かかりますので
ご承知ください。
（フリーズしたように見えますが、動いています）

なお、VBAだけで画像を取得する処理は
以下となります。

動作しなかった原因は、URL列に
URL以外のデータが入っており、
エラーとなっていたため、
エラー処理を追記しました。

--------------------
Public Const img_column As String = "L"
Public Const img_url_column As String = "K"
Public Const img_start_row As Long = 4

Sub load_image()
Dim r As Long
Dim rng As Range
Dim delrng As Range
Dim sh As Shape

' すでに埋め込まれている画像を先に削除する
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Pictures
Set delrng = Range(img_column & ":" & img_column)
Set T = shp.TopLeftCell
Set B = shp.BottomRightCell
If Not Intersect(delrng, T) Is Nothing Then
If Not Intersect(delrng, B) Is Nothing Then
shp.Delete
End If
End If
Next
Application.ScreenUpdating = True

On Error GoTo ErrorHandler
' URL列から画像を取得して画像列に埋め込む
For r = img_start_row To Range(img_url_column & Rows.Count).End(xlUp).Row
Set rng = Range(img_column & r)
If Not VarType(Range(img_url_column & r).Value) = 8 Then
    GoTo CONTINUE
End If

Set sh = ActiveSheet.Shapes.AddPicture(Range(img_url_column & r).Value, False, True, 0, rng.Top, 0, 0)
sh.LockAspectRatio = True
sh.ScaleHeight 1, msoTrue
sh.ScaleWidth 1, msoTrue
sh.Height = rng.Height
If sh.Width < rng.Width Then
sh.Left = rng.Left + (rng.Width - sh.Width) / 2
Else
sh.Width = rng.Width
sh.Top = (rng.Height - sh.Height) / 2
End If
ErrorHandler:
'    MsgBox ("画像がありません:" & Range(img_url_column & r).Value)
CONTINUE:
Next

End Sub###HR######FILE04ada6b1abafdb2ed7efdb72108d8c196.xlsbFILE0###

Answer

ECマスターズの山本です。

IMAGE関数が使えない場合は、
VBAマクロを利用して特定のセルにある
URLから画像を取得して別のセルに埋め込む
方法があります。

以下に画像URLをB列に指定して、
A列に画像をオブジェクトとして埋め込む
サンプルコードを添付いたします。

また、サンプルコードを埋め込んだ
Excelも添付しますので参考にしてください。
（サンプルのExcelはボタンを押すと動作します）

--------------------------
Sub load_image()
    Dim r As Long
    Dim rng As Range
    Dim delrng As Range
    Dim sh As Shape
    Dim shp As Shape
    Dim img_column As String
    Dim img_url_column As String
    Dim img_start_row As Long

    ' 画像を表示する列名
    img_column = "A"
    ' 画像URLの列名
    img_url_column = "B"
    '画像URLデータの開始行
    img_start_row = 2
 
    ' すでに埋め込まれている画像を先に削除する
    Application.ScreenUpdating = False
    For Each shp In ActiveSheet.Shapes
        Set delrng = Range(img_column & ":" & img_column)
        Set T = shp.TopLeftCell
        Set B = shp.BottomRightCell
        If Not Intersect(delrng, T) Is Nothing Then
            If Not Intersect(delrng, B) Is Nothing Then
                shp.Delete
            End If
        End If
    Next
    Application.ScreenUpdating = True
 
    ' URL列から画像を取得して画像列に埋め込む
    For r = img_start_row To Range(img_url_column & Rows.Count).End(xlUp).Row
        Set rng = Range(img_column & r)
        Set sh = ActiveSheet.Shapes.AddPicture(Range(img_url_column & r).Value, False, True, 0, rng.Top, 0, 0)
        sh.LockAspectRatio = True
        sh.ScaleHeight 1, msoTrue
        sh.ScaleWidth 1, msoTrue
        sh.Height = rng.Height
        If sh.Width < rng.Width Then
            sh.Left = (rng.Width - sh.Width) / 2
        Else
            sh.Width = rng.Width
            sh.Top = (rng.Height - sh.Height) / 2
        End If
    Next

End Sub
--------------------------###HR######FILE0e76b7a83926597b988b0707dd8d146dc.xlsmFILE0###

Answer

ECマスターズ　山本様

先日はご丁寧に教えていただき、ありがとうございました。
ご連絡いただいてからマクロを設定してみましたが、
添付シートのL1へボタンを作成し、マクロを実行すると
Set sh = ActiveSheet.Shapes.AddPicture(Range(img_url_column & r).Value, False, True, 0, rng.Top, 0, 0)
の部分でエラーになります。
中断するとボタンが消えてしまい、画像をURLの右側L列に表示させたいのですが、左側の「画像」の部分に表示されます。
再度マクロを実行しようとすると、次は
Set T = shp.TopLeftCell
の部分でエラーとなります。

設定しているマクロは画像とURLの列の部分しか変えていませんが、下記のとおりです。

Sub load_image()
Dim r As Long
Dim rng As Range
Dim delrng As Range
Dim sh As Shape
Dim shp As Shape
Dim img_column As String
Dim img_url_column As String
Dim img_start_row As Long

' 画像を表示する列名
img_column = "L"
' 画像URLの列名
img_url_column = "K"
'画像URLデータの開始行
img_start_row = 4

' すでに埋め込まれている画像を先に削除する
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Shapes
Set delrng = Range(img_column & ":" & img_column)
Set T = shp.TopLeftCell
Set B = shp.BottomRightCell
If Not Intersect(delrng, T) Is Nothing Then
If Not Intersect(delrng, B) Is Nothing Then
shp.Delete
End If
End If
Next
Application.ScreenUpdating = True

' URL列から画像を取得して画像列に埋め込む
For r = img_start_row To Range(img_url_column & Rows.Count).End(xlUp).Row
Set rng = Range(img_column & r)
Set sh = ActiveSheet.Shapes.AddPicture(Range(img_url_column & r).Value, False, True, 0, rng.Top, 0, 0)
sh.LockAspectRatio = True
sh.ScaleHeight 1, msoTrue
sh.ScaleWidth 1, msoTrue
sh.Height = rng.Height
If sh.Width < rng.Width Then
sh.Left = (rng.Width - sh.Width) / 2
Else
sh.Width = rng.Width
sh.Top = (rng.Height - sh.Height) / 2
End If
Next

End Sub

エラーとなったファイルを添付いたします。
ファイル名はダウンロードした時のままのものです。
見ていただけますと幸いです。

Answer

ECマスターズの山本です。

申し訳ありません。
添付ファイルがないようですので、
最初の投稿の右下の
「投稿内容について報告する」
より、ファイルを添付頂けないでしょうか。

よろしくお願いいたします。

Answer

ECマスターズの山本です。

ファイルの添付をありがとうございます。
VBAProjectにパスワードロックが
かかっているようですので、
再度「投稿内容について報告する」より
パスワードのご連絡をお願いいたします。

よろしくお願いいたします。

Answer

ECマスターズ　山本さま

お送りしたシートは御社提供のシートのため、VBAのパスワードはこちらで設定しておりません。
返信欄に記載したマクロは個人用で作成して動かしてみたものです。

何度もお手数をおかけしてすみません。

Answer

ECマスターズの山本です。

申し訳ありません。
状況把握いたしました。

確認しますので、今しばらくお待ちください。

Answer

ECマスターズ　山本様

ご連絡ありがとうございます。
いただいたマクロで問題無く画像が表示されました！
これで相当作業がしやすくなり、本当に助かります。
ありがとうございました。