How can I keep a cell's hyperlink after replacing its text with a picture?

Question

I am trying to replace some hyperlinked text in cells but keep the hyperlink there. In other words, instead of clicking the text to take you to the website that the hyperlink leads to, you would click the picture to go to that website.

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:\Users\xxx\Pictures"

    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

A Picture is a seperate object from the Cell. Your code is placing the picture over a cell, it's not actually "In" the cell.

You could move the hyperlink from the cell, to the Picture, like this

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