用图片替换单元格的文本后，如何保留单元格的超链接？

Question

我正在尝试替换单元格中的一些超链接文本，但将超链接保留在那里。换句话说，您不是单击文本将您带到超链接指向的网站，而是单击图片以转到该网站。

Option Explicit
Sub test()
    Dim MyPath As String
    Dim CurrCell As Range
    Dim Cell As Range
    Dim LastRow As Long
    Dim i As Long
    Application.ScreenUpdating = False
    MyPath = "C:UsersxxxPictures"
    If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
    Set CurrCell = ActiveCell
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    For i = 1 To LastRow
        Set Cell = Cells(i, "B")
        If Cell.Value <> "" Then
            If Dir(MyPath & Cell.Value & ".png") <> "" Then
                ActiveSheet.Pictures.Insert(MyPath & Cell.Value & ".png").Select
                With Selection.ShapeRange
                    .LockAspectRatio = msoFalse
                    .Left = Cell.Left
                    .Top = Cell.Top
                    .Width = Cell.Width
                    .Height = Cell.Height
                End With
            Else
                Cell.Value = "N/A"
            End If
        End If
    Next i
    CurrCell.Select
    Application.ScreenUpdating = True
End Sub

Answer 1

图片是独立于单元格的对象。 您的代码将图片放在单元格上，它实际上不是"在"单元格中。

您可以将超链接从单元格移动到图片，如下所示

Sub test()
    Dim MyPath As String
    Dim Cell As Range
    Dim shp As ShapeRange
    Dim ws As Worksheet
    Dim rng As Range
    Dim ext As String
    Dim HyperLinkAddr As String
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    MyPath = "C:Users" & Environ$("UserName") & "Pictures"
    ext = ".png"
    If Right(MyPath, 1) <> "" Then MyPath = MyPath & ""
    With ws
        Set rng = .Range(.Cells(1, 2), .Cells(.Rows.Count, "B").End(xlUp))
    End With
    For Each Cell In rng
        If Cell.Value <> vbNullString Then
            If Dir(MyPath & Cell.Value2 & ext) <> "" Then
                ' Get a reference to the inserted shape, rather than relying on Selection
                Set shp = ws.Pictures.Insert(MyPath & Cell.Value2 & ext).ShapeRange
                With shp
                    .LockAspectRatio = msoFalse
                    .Left = Cell.Left
                    .Top = Cell.Top
                    .Width = Cell.Width
                    .Height = Cell.Height
                    If Cell.Hyperlinks.Count > 0 Then
                        HyperLinkAddr = Cell.Hyperlinks(1).Address
                        Cell.Hyperlinks.Delete
                        ws.Hyperlinks.Add _
                          Anchor:=.Item(1), _
                          Address:=HyperLinkAddr
                    End If
                End With
            Else
                Cell.Value = "N/A"
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub