エクセルのマクロでリンク先の画像を表示させたい

いつもお世話になります。
よろしくお願いします。

B列にネット上の画像のurlが入っているとします。
https://www.softbankhawks.co.jp/entame/img/wallp …
https://www.softbankhawks.co.jp/entame/img/wallp …
https://www.softbankhawks.co.jp/entame/img/wallp …
https://www.softbankhawks.co.jp/entame/img/wallp …

この画像をA列で表示させるマクロを組みたいのですが可能でしょうか。
行数は場合によっては1000行くらいになる予定です。

質問者からの補足コメント

• 

  ただいま、当方側の問題がないPCで検証したところ、
  表示されました。
  
  長年の課題でしたので、とても助かりました。
  
  すごく感謝しております。
  ありがとうございました。

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/04/18 10:33

No.1 ベストアンサー 回答者： fujillin 回答日時： 2020/04/17 10:04

こんにちは

情報が少ないので、サンプル程度としてこんな感じ？

Sub sample()
Dim c As Range, u As String
Dim shp As Object, r As Double, rw As Long

For rw = 1 To Cells(Rows.Count, 2).End(xlUp).Row
Set c = Cells(rw, 1)
u = c.Offset(, 1).Text
If u <> "" Then

On Error Resume Next
　Set shp = ActiveSheet.Shapes.AddPicture( _
　Filename:=u, _
　linktofile:=False, _
　savewithdocument:=True, _
　Left:=c.Left, Top:=c.Top, _
　Width:=0, Height:=0 _
　)

　If Err = 0 Then
　　With shp
　　　.LockAspectRatio = False
　　　.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
　　　.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
　　　r = Application.Min(c.Width / .Width, c.Height / .Height)
　　　.Height = .Height * r
　　　.Width = .Width * r
　　　.LockAspectRatio = True
　　End With
　Else
　　c.Value = "取得失敗"
　End If
On Error GoTo 0
End If
Next rw
End Sub

この回答へのお礼

試したのですが、「取得失敗」となります。
これはこちらの問題かもしれず、一度該当画像をブラウザで正常表示させておけば、
ばっちり表示されます。

さすがに1000枚の画像を一度開いておくことはできませんので、解消できると助かります。

予め、必要画像をPC内に取り込んでおくことは可能です。
そうしたほうが良いようでしたら、そのように準備いたしますがいかがでしょうか。

お礼日時：2020/04/17 21:27

No.4 回答者： Qchan1962 回答日時： 2020/04/18 00:18

＃２，３続きです

＃３での問題を対処しました。

Sub sample2()
Dim i As Long
Dim strURL As String
Dim objShape As Object
On Error Resume Next
　　For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
　　　　If Range(Cells(i, 2).Address).Hyperlinks.Count > 0 Then
　　　　　　strURL = ActiveSheet.Cells(i, 2).Hyperlinks(1).Address
　　　　Else
　　　　　　strURL = ActiveSheet.Cells(i, 2).Value
　　　　End If
　　　　With Cells(i, 1)
　　　　　　Set objShape = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　　　　　　 Filename:=strURL, linktofile:=False, _
　　　　　　　　　　　　　 savewithdocument:=True, Left:=.Left, _
　　　　　　　　　　　　　 Top:=.Top, Width:=.Width, Height:=.Height)
　　　　　　objShape.ScaleHeight 1, msoTrue
　　　　　　objShape.ScaleWidth 1, msoTrue
　　　　End With
　　Next
End Sub

この回答へのお礼

せっかく作っていただきましたが、2点問題がございます。

●まず、いまこちらのPCの問題だと思うのですが、リンクを踏んでいない画像に関しては表示されません。

●踏んだ画像に関しても、元の大きさが反映されるようでセルからはみ出します(これはわたしが指定していなかったのですから仕方がないと思います)

一つ目の問題が解消しないので、いま今回のそもそものお願いが検証できない状態です。

お礼日時：2020/04/18 10:09

No.3 回答者： Qchan1962 回答日時： 2020/04/17 23:55

＃２です。

基本的に＃１さんと同じでした。よく見ず、すみません。

＞、一度該当画像をブラウザで正常表示させておけば、ばっちり表示されます。

B列のアドレスは　https://www.softbankhawks.co.jp/entame/img/wallp …　の様な表示になっていませんか？
ちゃんと　～://www.softbankhawks.co.jp/entame/img/wallpaper/2019/wp1912_1s.jpg　の様に表示されていますか？
～はhttpsです。

いずれも、ブラウザではアクセスできますが、、

No.2 回答者： Qchan1962 回答日時： 2020/04/17 23:36

この様な感じではいかがでしょう。

サイズや場所の変更はお任せいたします。
エラー処理は加えていません。

Sub sample()
Dim i As Long
Dim strURL As String
Dim objShape As Object
　　For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
　　　　strURL = ActiveSheet.Cells(i, 2)
　　　　With Cells(i, 1)
　　　　　　Set objShape = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　　　　　　 Filename:=strURL, LinkToFile:=False, _
　　　　　　　　　　　　　 SaveWithDocument:=True, Left:=.Left, _
　　　　　　　　　　　　　 Top:=.Top, Width:=.Width, Height:=.Height)
　　　　　　objShape.ScaleHeight 1, msoTrue
　　　　　　objShape.ScaleWidth 1, msoTrue
　　　　End With
　　Next
End Sub

この回答へのお礼

失礼いたしました。
サイズ変更についてはされていないと記載ございましたね。

お礼日時：2020/04/18 10:20