☰

Excel VBA從超連結公式中提取超鏈接

tag-icon • tag-icon microsoft-excel vba hyperlink
Excel VBA從超連結公式中提取超鏈接

我正在嘗試編寫 VBA 程式碼來驗證電子表格上的連結。我一直運行良好，直到我遇到從公式創建的超連結。例如=Hyperlink(A1,"Link1")或=Hyperlink(A1&A2,"Link2")

標準Hyperlinks(1).AddressVBA 不會將這些註冊為具有鏈接，並且我在網上找不到任何其他解決方案。

有任何想法嗎？

答案1

這是一個簡單的方法，可以處理一些你的公式。說A1包含公式：

=HYPERLINK("http://www.google.com","search")

如果我們選擇它並運行：

Sub HyperChecker()
    Dim s1 As String, s2 As String, arr

    s1 = ActiveCell.Formula
    s2 = Mid(s1, 12)
    arr = Split(s2, ",")
    MsgBox arr(0)
End Sub

我們得到：

在此輸入影像描述

程式碼會丟棄公式的開頭和結尾並傳回 URL。

如果函數的第一個參數是一個，就會出現問題表達而不是一個字串常數。

然後你就需要EVALUATE()那個表達。

答案2

對於更一般的情況，您可以簡單地使用以下內容：

url_formula = Split(Mid(cell.formula, 12), ",")(0)
Debug.Print Evaluate(url_formula)

whereMid(cell.formula, 12)去掉=HYPERLINK(公式的一部分，並Split(..., ",")(0)在逗號部分分割公式的其餘部分（(0)選擇分割的第一部分 - 因此與 Excel 中的大多數索引不同，它是從零開始的）。

然後，使用該Evaluate函數計算結果表達式。這應該是相當通用的，至少與Evaluate函數允許的一樣通用。

答案3

其他答案不能很好地處理公式中的變化。例如，如果公式同時包含 LINK_LOCATION 參數和 FRIENDLY_NAME 參數，則它們會失敗。如果公式在某些區域有額外的空格或換行符，其他也會失敗。

這個答案並不完美，但它比我發布此文章之日發現的其他答案更好。我已經確定了該程式碼可以工作的情況和失敗的情況。

此 VBA 函數有點長，但它會從 HYPERLINK() 公式或嵌入單元格中的非公式超連結中提取超連結的 URL/位址。

它首先檢查非公式超鏈接，因為這是最簡單且最可靠的提取超鏈接。如果不存在，它將檢查公式中的超連結。

只有當 HYPERLINK() 函數之外除等號外沒有任何內容時，從公式中提取才有效。

可接受的 HYPERLINK() 公式

它將要運用這個公式：

=HYPERLINK("https://" & A1, "My Company Website")

它將要也研究這個公式（注意額外的空格和換行符）：

=    
HYPERLINK(     "https://" & A1, 
         "My Company Website" & B2)

它會不是運用這個公式：

=IF(  LEN(A1)=0, "", HYPERLINK("https://" & A1, "My Company Website")  )

功能

Function HyperLinkText(ByVal Target As Excel.Range) As String
    
    ' If TARGET is multiple cells, only check the first cell.
    Dim firstCellInTarget As Excel.Range
    Set firstCellInTarget = Target.Cells.Item(1)
    
    
    Dim returnString As String
    
    
    ' First check if the cell contains a non-formula hyperlink.
    If Target.Hyperlinks.Count > 0 Then
        ' Cell contains a non-formula hyperlink.
        returnString = Target.Hyperlinks.Item(1).Address    ' extract hyperlink text from the Hyperlinks property of the range
    
    Else
        ' Cell does -NOT- contain a non-formula hyperlink.
        '   Check for a formula hyperlink.
        Dim targetFormula As String
        targetFormula = firstCellInTarget.Formula
        
        
        
        Dim firstOpenParenthesisIndex As Long
        firstOpenParenthesisIndex = VBA.InStr(1, _
                                              targetFormula, _
                                              "(", _
                                              VbCompareMethod.vbBinaryCompare)
        
        Dim cleanFormulaHyperlinkPrefix As String
        cleanFormulaHyperlinkPrefix = Left$(targetFormula, firstOpenParenthesisIndex)
        cleanFormulaHyperlinkPrefix = Replace$(Replace$(Replace$(cleanFormulaHyperlinkPrefix, Space$(1), vbNullString), vbCr, vbNewLine), vbLf, vbNullString)
        
        Dim cleanFormulaPart2 As String
        cleanFormulaPart2 = Mid$(targetFormula, firstOpenParenthesisIndex + 1)
        
        Dim cleanFormulaCombined As String
        cleanFormulaCombined = cleanFormulaHyperlinkPrefix & cleanFormulaPart2
        
        
        ' Get all text inside the HYPERLINK() function.
        '   This is either a single LINK_LOCATION parameter or both the
        '   LINK_LOCATION and FRIENDLY_NAME parameters separated by a comma.
        '
        '   Ex. 1 Parameter:        "https://" & $A$1
        '   Ex. 2 Parameters:       "https://" & $A$1, "Click Here To Open the Company URL"
        '
        Const HYPERLINK_FORMULA_PREFIX As String = "=HYPERLINK("
                
        Dim tmpString As String
        tmpString = Mid$(cleanFormulaCombined, VBA.Len(HYPERLINK_FORMULA_PREFIX) + 1)
        
        Dim textInsideHyperlinkFunction As String
        textInsideHyperlinkFunction = Left$(tmpString, VBA.Len(tmpString) - 1)
        
        
        ' Get the first parameter (LINK_LOCATION) from the text inside the HYPERLINK()
        '   function by using =EVALUATE().  If text inside the HYPERLINK() function
        '   contains two parameters, they will be separated by a comma and EVALUATE()
        '   will return an error.  Start with the entire text inside the HYPERLINK()
        '   function.  If EVALUATE() returns an error, remove one character from the end
        '   of the string being evaluated and try again.  Eventually only one parameter
        '   will be evaluated and EVALUATE() will return a text string.
        '
        '   For example, if the string to be evaluated is:
        '
        '       "https://" & $A$1, "Click Here To Open the Company URL"
        '
        '   and cell A1 contains:
        '
        '       mycompany.com
        '
        '   EVALUATE will return:
        '
        '       https://mycompany.com
        '
        Dim hyperlinkLinkLocation As String
        Dim i As Long
        For i = VBA.Len(textInsideHyperlinkFunction) To 1 Step -1   ' with each failure, shrink length of string-to-evaluate by one

            If Not VBA.IsError(Excel.Application.Evaluate("=" & Left$(textInsideHyperlinkFunction, i))) Then
                hyperlinkLinkLocation = Excel.Application.Evaluate("=" & Left$(textInsideHyperlinkFunction, i))
                Exit For        ' ****
            End If

        Next i
        
        returnString = hyperlinkLinkLocation

    End If
    
    
    ' Return the hyperlink string.
    HyperLinkText = returnString
End Function

如何使用該功能

Sub Test()
    ' Display hyperlink of the first cell
    '    in the currently selected range.
    Msgbox HyperLinkText(Selection) ' displays the hyperlink of the first cell
End Sub

相關內容