Как сохранить гиперссылку ячейки после замены текста на изображение?

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:\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

Изображение - это отдельный объект от ячейки.Ваш код размещает изображение над ячейкой, на самом деле оно не находится внутри ячейки.

Вы можете переместить гиперссылку из ячейки на изображение, например,

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