我使用VBA函数在Excel中提取超链接，需要返回链接，如果不是超链接则需要返回“”

Question

我使用带有嵌入函数的 Excel 电子表格来返回超链接的单元格。当单元格没有超链接时，工作表返回“#VALUE！”，我希望它返回空值（“”）。如何更新函数以返回链接，或返回“”...？

这是这个函数，它工作得很好 - 我只想添加“如果 URL 存在，则返回它，如果不是 URL，则“”：

Function URL(Hyperlink As Range)
   URL = Hyperlink.Hyperlinks(1).Address
End Function

Answer 1

这段代码应该给出OP所要求的内容。

fnCheckHyperlink 是主要调用函数。

如果单元格中确实有超链接，

fnHasHyperlink 将返回

True

。

fnURLExists 使用超链接中的地址并检查它是否存在。

fnHyperlinkAdd 包装了 Range 的

.Hyperlink.Add

方法，对于设置测试数据很有用。

Option Explicit

Sub sbUsage()
 MsgBox fnCheckHyperlink(Range("A1"))
 MsgBox fnCheckHyperlink(Range("G1"))
End Sub

'"if URL exists, return it, if not a URL, then "" - Null
Public Function fnCheckHyperlink(rCell As Range) As String
    ' if URL exists ...
    ' 1. if cell has hyperlink
    ' 2. if URL exists
    ' so return it
 
 If fnHasHyperlink(rCell) Then
    If fnURLExists(rCell.Hyperlinks(1).Address) Then
        fnCheckHyperlink = rCell.Hyperlinks(1).Address
    Else
        fnCheckHyperlink = ""
    End If
 Else
    fnCheckHyperlink = ""
 End If
End Function

Public Function fnURLExists(sURL As String) As Boolean
    On Error GoTo fnURLExists_Error
    Dim htRequest As New WinHttpRequest
    htRequest.Open "HEAD", sURL
    htRequest.Send
    If htRequest.Status = 200 Then
        fnURLExists = True
    Else
        fnURLExists = False
    End If
    Exit Function

fnURLExists_Error:
    'sbPrint ("fnURLExists_Error" & Err.Number & Err.Description)
    ' fnURLExists_Error -2147012890 The URL does not use a recognized protocol
    fnURLExists = False
End Function
Sub sbPrint(sText As String): Open "C:\tmp\z-" & Format(Now(), "HHMMSS") & ".txt" For Output As #1: Print #1, sText: Close #1: End Sub

Public Function fnHasHyperlink(rCell As Range) As Boolean
 If rCell.Hyperlinks.Count > 0 Then
    fnHasHyperlink = True
 Else
    fnHasHyperlink = False
 End If
 End Function

' https://learn.microsoft.com/en-us/office/vba/api/excel.range(object)#properties
' https://www.mrexcel.com/board/threads/what-is-the-proper-vba-syntax-to-check-if-a-cell-contains-a-hyperlink.849362/
' https://stackoverflow.com/questions/78142219/i-use-a-vb-function-to-extract-a-hyperlink-in-excel-need-to-return-either-the-l
' https://support.microsoft.com/en-gb/office/hyperlink-subaddress-fields-e46d7aa0-a71d-4289-a423-2a3e31c35f50
' https://learn.microsoft.com/en-us/office/vba/api/excel.hyperlinks.add
' expression.Add (Anchor, Address, SubAddress, ScreenTip, TextToDisplay)
' https://stackoverflow.com/questions/28770412/vba-function-optional-parameters
' https://stackoverflow.com/questions/58117601/vba-code-to-know-url-validity-that-will-check-whether-url-is-exist-or-not

Public Function fnHyperlinkAdd(rnAnchor As Range, sAddress As String, Optional sSubAddress As String, Optional sScreenTip As String, Optional sTextToDisplay As String) As Boolean
 On Error GoTo fnHyperlinkAdd_Error
 With Sheets(1)
    .Hyperlinks.Add _
        Anchor:=rnAnchor, _
        Address:=sAddress, _
        SubAddress:=sSubAddress, _
        ScreenTip:=sScreenTip, _
        TextToDisplay:=sTextToDisplay
 End With
 fnHyperlinkAdd = True
 Exit Function

fnHyperlinkAdd_Error:
 fnHyperlinkAdd = False
End Function