Question

我的工作表有三列，“A”=图像，“B”=图像名称，“C”= URL链接，第1行和第2行用作标题，行3到1002用作用户输入。当前工作代码将在您选择的文件夹中的列“B”中搜索图像名称，并将它们插入到列“A”中。这个宏运行了我已经创建的用户窗体上的命令按钮。

工作代码如下（这是已接受答案here的编辑版本）：

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

我正在寻找一种方法来编辑这个宏，以便它能够使用列“C”中图像的URL链接，并找到并以这种方式将图像插入到列“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链接列表工作了一次，然后我删除了中间的一个链接，看它是否能正确处理空白单元格，现在它完全无法工作。它每次进入“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

我把那条强制它的线加到了“ExitRoutine”上。我不确定这条线是如何工作的，因为我不是最初编写它的人。任何帮助都会很棒！

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开始，那么您将跳过输入数据的前两行：两个维度中的二维数组始终具有下限1，无论其位置如何范围。

在这种情况下，data(1,1)将对应于C3，而data(3,1)则为C5

通过URL链接将图像放到Excel工作表上

1 个答案: