通过Excel VBA安装URL图片

Question

我正在寻求帮助我正试图找到以下宏的解决方案： 第一个问题我想在列a上粘贴网址，我希望列b上的结果图片在链接列a上具有相同的大小

Sub InstallPictures()
    Dim i As Long, v As String
    On Error Resume Next
        For i = 2 To 1903
            v = Cells(i, "a").Value
            If v = "" Then Exit Sub
            With ActiveSheet.Pictures
                .Insert (v)
            End With
        Next i
    On Error GoTo 0
End Sub

Answer 1

试试这个

Sub InstallPictures()
Dim i As Long
Dim v As String
Dim sht As Worksheet
Dim colWithUrl As Long, colWithPics As Long

colWithUrl = 1
colWithPics = 2

Set sht = ThisWorkbook.Sheets("picture")
With sht
    .Columns(colWithPics).ColumnWidth = .Columns(colWithUrl).ColumnWidth
    For i = 2 To 3
        v = .Cells(i, colWithUrl).Value
        If v <> "" Then Call setPic(ActiveSheet.Pictures.Insert(v), .Cells(i, colWithPics), .Cells(i, colWithUrl))
    Next i
End With

End Sub


Sub setPic(myPic As Picture, cellToMoveImageTo As Range, cellToCopySizeFrom As Range)

With myPic.ShapeRange
    ' move image to have its upper left corner as the "cellToMoveImageTo" cell one
    .Left = cellToMoveImageTo.Left
    .Top = cellToMoveImageTo.Top


    ' resize the image to fit the "cellToCopySizeFrom" size
    .LockAspectRatio = False '<== you have to do that otherwise the original picture aspect ratio will stay and won't fit the aspect ratio of the cell whose upper left corner it shares
    .Height = cellToCopySizeFrom.Height
    .Width = cellToCopySizeFrom.Width

End With
End Sub