URLリンクを使用してExcelシートに画像を貼る

Question

シートには、「A」=画像、「B」=画像名、および「C」= URLリンクの3つの列があり、行1と2がヘッダーと行として使用されます3から1002はユーザー入力用です。現在の作業コードは、選択したフォルダの列 "B"のイメージ名を検索し、列 "A"に挿入します。このマクロは、私が作成したユーザーフォームに配置したコマンドボタンから実行されます。 URLを使用することになるよう

Private Sub Add_Images_Click() 
Const EXIT_TEXT   As String = "" 
Const NO_PICTURE_FOUND As String = "No picture found" 

Dim picName    As String 
Dim picFullName   As String 
Dim rowIndex   As Long 
Dim lastRow    As Long 
Dim selectedFolder  As String 
Dim data()    As Variant 
Dim wks     As Worksheet 
Dim Cell    As Range 
Dim pic     As Picture 

On Error GoTo ErrorHandler 

selectedFolder = GetFolder 
If Len(selectedFolder) = 0 Then GoTo ExitRoutine 

Application.ScreenUpdating = False 

Set wks = ActiveSheet 
lastRow = wks.Cells(2, "B").End(xlDown).Row 
data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2 

For rowIndex = 3 To UBound(data, 1) 
    If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine 

    picName = data(rowIndex, 1) 
    picFullName = selectedFolder & picName 

    If Len(Dir(picFullName)) > 0 Then 
     Set Cell = wks.Cells(rowIndex, "A") 
     Set pic = wks.Pictures.Insert(picFullName) 
     With pic 
      .ShapeRange.LockAspectRatio = msoFalse 
      .Height = Cell.Height 
      .Width = Cell.Width 
      .Top = Cell.Top 
      .Left = Cell.Left 
      .Placement = xlMoveAndSize 
     End With 
    Else 
     wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND 
    End If 
Next rowIndex 

ExitRoutine: 
Set wks = Nothing 
Set pic = Nothing 
Application.ScreenUpdating = True 
UserForm.Hide 
Exit Sub 

ErrorHandler: 
MsgBox Prompt:="Unable to find photo", _ 
     Title:="An error occured", _ 
     Buttons:=vbExclamation 
Resume ExitRoutine 

End Sub 
Private Function GetFolder() As String 
Dim selectedFolder As String 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .InitialFileName = Application.DefaultFilePath & "\" 
    .Title = "Select the folder containing the Image/PDF files." 
    .Show 

    If .SelectedItems.count > 0 Then 
     selectedFolder = .SelectedItems(1) 
     If Right$(selectedFolder, 1) <> Application.PathSeparator Then _ 
      selectedFolder = selectedFolder & Application.PathSeparator 
    End If 
End With 
GetFolder = selectedFolder 
End Function 

私はこのマクロを編集する方法を探しています：以下のように

作業するコードがある（これは受け入れ答えhereの編集されたバージョンです）列 "C"の画像をリンクし、画像を見つけて列 "A"に挿入します。私は現在のコードに適合させようとしている作業コードを見つけました（どこに覚えていないか、リンクしています）。

私はオンラインで見つけるサンプルコード：

Sub Images_Via_URL() 
Dim url_column As Range 
Dim image_column As Range 

Set url_column = Worksheets(1).UsedRange.Columns("A") 
Set image_column = Worksheets(1).UsedRange.Columns("B") 

Dim i As Long 
For i = 2 To url_column.Cells.Count 

    With image_column.Worksheet.Pictures.Insert(url_column.Cells(i).Value) 
    .Left = image_column.Cells(i).Left 
    .Top = image_column.Cells(i).Top 
    .Height = 100 
    .Width = 100 
    End With 
Next 
End Sub 

次のコードは、それを自分で編集する私の失敗した試みです。それは7つのURLリンクのリストのために一度働いた、そして私は空のセルを正しく扱うかどうかを見るために真ん中のリンクの1つを削除しました。それは毎回 "ExitRoutine"に入ります。

が動作しないコード：私は「ExitRoutine」にそれを強制された行を太字にしました

Option Explicit 
Private Sub URL_Images_Click() 

Const EXIT_TEXT   As String = "" 
Const NO_PICTURE_FOUND As String = "No picture found" 

Dim picURL    As String 
Dim rowIndex   As Long 
Dim lastRow    As Long 
Dim data()    As Variant 
Dim wks     As Worksheet 
Dim Cell    As Range 
Dim pic     As Picture 

On Error GoTo ErrorHandler 

Application.ScreenUpdating = False 

Set wks = ActiveSheet 
lastRow = wks.Cells(2, "B").End(xlDown).Row 
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2 

For rowIndex = 3 To UBound(data, 1) 
    **If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine** 

    picURL = data(rowIndex, 1) 

    If Len(picURL) > 0 Then 
     Set Cell = wks.Cells(rowIndex, "A") 
     Set pic = wks.Pictures.Insert(picURL) 
     With pic 
      .ShapeRange.LockAspectRatio = msoFalse 
      .Height = Cell.Height 
      .Width = Cell.Width 
      .Top = Cell.Top 
      .Left = Cell.Left 
      .Placement = xlMoveAndSize 
     End With 
    Else 
     wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND 
    End If 

Next rowIndex 

ExitRoutine: 
Set wks = Nothing 
Set pic = Nothing 
Application.ScreenUpdating = True 
UserForm.Hide 
Exit Sub 

ErrorHandler: 
MsgBox Prompt:="Unable to find photo", _ 
     Title:="An error occured", _ 
     Buttons:=vbExclamation 
Resume ExitRoutine 

End Sub 

。私は最初にそれを書いた人ではないので、その行がどのくらい正確に機能するかはわかりません。どんな助けも素晴らしいだろう！

Answer 1

lastRow = wks.Cells(2, "B").End(xlDown).Row 
data = wks.Range(wks.Cells(3, "C"), wks.Cells(lastRow, "C")).Value2 

For rowIndex = 3 To UBound(data, 1) 
    '.... 

あなたはrowIndexに= 3で開始した場合、あなたはあなたの入力データの最初の2行を飛ばしている：範囲からの2次元配列は、常に場所に関係なく、両方の次元1の下限を有しています範囲の。

data(1,1)は、C3に対応します。この場合

、data(3,1)はC5

ある