☰

Excel VBA для извлечения гиперссылки из формулы гиперссылки

tag-icon • tag-icon microsoft-excel vba hyperlink
Excel VBA для извлечения гиперссылки из формулы гиперссылки

Я пытаюсь написать код VBA для проверки ссылок в таблице. Он работал хорошо, пока я не столкнулся с Гиперссылками, созданными из формулы. Например, =Hyperlink(A1,"Link1")или=Hyperlink(A1&A2,"Link2")

Стандартный Hyperlinks(1).AddressVBA не регистрирует их как имеющие ссылку, и я не могу найти других решений в Интернете.

Есть идеи?

решение1

Вот простой подход, который справится с этой задачей.некоторыйваших формул. СкажитеА1содержит формулу:

=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)

Where Mid(cell.formula, 12)избавляется от =HYPERLINK(части формулы и Split(..., ",")(0)разделяет остальную часть формулы по запятой ( (0)выбирает первую часть разделения и, таким образом, отсчитывается от нуля, в отличие от большинства индексов в Excel).

Затем используйте Evaluateфункцию для оценки полученного выражения. Оно должно быть достаточно общим, по крайней мере настолько общим, насколько Evaluateпозволяет функция.

решение3

Другие ответы не очень хорошо обрабатывают вариации в формуле. Например, они не справляются, если формула содержит как параметр LINK_LOCATION, так и параметр FRIENDLY_NAME. Другие также не справляются, если формула содержит лишние пробелы или переносы строк в определенных областях.

Этот ответ не идеален, но он работает лучше, чем другие ответы, которые я нашел на дату публикации. Я определил случаи, когда этот код будет работать, а когда он даст сбой.

Эта функция VBA немного длинная, но она извлечет URL/адрес гиперссылки либо из формулы HYPERLINK(), либо из гиперссылки, не являющейся формулой, встроенной в ячейку.

Сначала он проверяет наличие гиперссылки, не являющейся формулой, поскольку это самая простая и надежная извлекаемая гиперссылка. Если ее нет, он проверяет наличие гиперссылки в формуле.

Извлечение из формулы работает ТОЛЬКО в том случае, если за пределами функции 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

Связанный контент