Question

我在网上查了很多解决方案，但我似乎无法找到符合我要求的任何解决方案

单元格A1，A2及以后包含指向图片的链接单元格B1，B2等包含我的VBA从文件夹中抓取的图片。我希望B中的每张照片都包含链接，这样当您点击图片时，它就会转到照片网址我有：

Sub Adwadwawda()

Dim mylink As String
Dim pic As Shape
Dim lnk As Hyperlink

mylink = "www.pageurl.com"

Set pic = Worksheets("Sheet1").Shapes("Picture 1")

Set lnk = Worksheets("Sheet1").Hyperlinks.Add(Anchor:=pic, Address:=mylink)

End Sub

我正在尝试修改它以使每个单元格向左E.g B3 Photo想要A3链接。范围（每列A和B中的行数）会随着照片的添加而每天更改。

VBA从文件夹添加图片..

Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("Sheet1").Activate
    Folderpath = "C:\Users\Pictures\Saved Pictures"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                  Sheets("Sheet1").Range("A" & counter).Value = fls.Name
                  Sheets("Sheet1").Range("C" & counter).ColumnWidth = 25
                Sheets("Sheet1").Range("C" & counter).RowHeight = 100
                Sheets("Sheet1").Range("C" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Sheet1").Activate
            End If

        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 50
            .Height = 70
        End With
        .Left = ActiveSheet.Range("B" & counter).Left
        .Top = ActiveSheet.Range("B" & counter).Top
        .Placement = 1
        .PrintObject = True

    End With

End Function

Answer 1

最简单的方法是循环遍历所有形状，使用TopLeftCell属性和offset来读取从左边的单元格到左上角所在单元格的链接地址：

Sub Adwadwawda()
Dim Shp As Shape, ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
    For Each Shp In ws.Shapes
        If Shp.TopLeftCell.Column = 2 Then _
            ws.Hyperlinks.Add Shp, Shp.TopLeftCell.Offset(0, -1).Value
    Next
End Sub

将链接插入其旁边的图像行（例如B2照片想要A2链接]

1 个答案: