我正在尝试编写 VBA 代码来验证电子表格上的链接。我一直运行良好,直到我遇到了从公式创建的超链接。例如=Hyperlink(A1,"Link1")
或=Hyperlink(A1&A2,"Link2")
标准Hyperlinks(1).Address
VBA 没有将这些注册为具有链接,并且我在网上找不到任何其他解决方案。
有任何想法吗?
答案1
答案2
对于更一般的情况,您可以简单地使用类似以下内容:
url_formula = Split(Mid(cell.formula, 12), ",")(0)
Debug.Print Evaluate(url_formula)
其中,Mid(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