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

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

1 个答案: