URL bağlantıları aracılığıyla bir excel sayfasına görüntülerin yerleştirilmesi

Question

Sayfamın üç sütunu var, "A" = Görüntüler, "B" = Resim Adları ve "C" = Satır 1 ve 2 olan URL Bağlantıları, üstbilgi ve satır olarak kullanılıyor Kullanıcı girişi için 3 ila 1002. Geçerli çalışma kodu, seçtiğiniz klasördeki "B" sütununda görüntü adlarını arar ve bunları "A" sütununa ekler. Bu makro, oluşturduğum bir kullanıcı formuna koyduğum bir komut düğmesinden çıkıyor. o URL kullanmak mümkün olacaktır böylece

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 

Bu makro düzenlemek için bir yol arıyorum şu şekildedir:

Çalışma kodudur (bu kabul edilen yanıt here bir düzenlenmiş versiyonu) "C" Sütunundaki resimlere bağlantılar verin ve görüntüleri "A" sütununa bu şekilde bulup ekleyin. İstenen sonuçları elde etmek için mevcut kodumla uyum sağlamaya çalıştığım bir çalışma kodu buldum (nerede olduğunu hatırlayamıyorum veya bağlantı kuramazdım).

İnternet'te bulduğum örnek kod:

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 

Aşağıdaki kod kendim düzenlemek için benim başarısız girişimi. Bir kez 7 URL bağlantısı listesi için çalıştı, daha sonra boş hücreyi doğru bir şekilde ele alıp almayacağını görmek için ortadaki bağlantılardan birini sildim ve şimdi işe yaramadı. Her seferinde "ExitRoutine" e gider.

Çalışmıyor Kodu: Ben "ExitRoutine" bunu zorluyor çizgi kalın ettik

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 

. Bu çizginin tam olarak yazdığı gibi olmadığına emin değilim. Herhangi bir yardım harika olurdu!

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) 
    '.... 

Eğer RowIndex başlarsanız = 3 o zaman girdi verisinin ilk iki sıra atlıyorsun: konumdan bağımsız bir dizi her zaman her iki boyut için 1 alt sınır vardır bir 2-B dizisi, aralığın data(3,1) ise data(1,1) C3 karşılık bu durumda

, `lastRow` başarısız değeri ne var C5