如何从动态生成超链接（通过公式）的单元格中获取地址（链接）？

Question

在 excel 中，您可以链接超链接（到单元格、到绘图等）

我们可以说这些链接分为两种：

1. 硬链接 此功能可以通过直接编辑单元格或对象来实现，即通过右键单击并链接链接（到文档中的某个位置、到网页等），或者在 VBA 中通过调用超链接对象

所以这个链接在单元格属性中是可见的，而且！在超链接集合中可见

1. 动态生成的超链接是指单元格具有符合以下原则的公式的情况

=HYPERLINK(B2;A2)

A2 包含显示名称，例如“Trade Minipigs”，B2 包含实际地址

对于用户来说，一切都与第 1 项的情况大致相同，但它在 Hyperlinks 集合中不再可见

但是！让我们假设公式依赖于另一张纸上的单元格，它们仍然在某个地方，有一堆检查和其他东西，通常很复杂，我们需要向某人发送这张带有最终链接的表格（但不是这些表格所指向的表格）生成的链接参考）

在这种情况下，如果将工作表复制到新文件，公式中的单元格引用将更正并指向复制工作表的文件

很明显，收件人没有这样的文件，这些链接对他不起作用（但是，在超链接本身的部分，它甚至不起作用，但与显示名称相关的部分按预期工作）

“复制和粘贴”（值）操作将无济于事，因为在这种情况下，公式将在显示名称部分进行计算，但不会插入生成的链接（链接时也会发生同样的情况新文件和旧文件之间的损坏）

就是这样，这个公式只是显示名称而不是超链接的单元格的“值”，它也不在单元格属性中 单元格属性超链接是硬超链接

我认为这个链接在 Excel 对象模型的深处是可用的 毕竟，当您将光标悬停在这样的单元格上时，是的，并且窗口会弹出此超链接。不过这很明显。

是否有可能通过软件以某种方式提取这个生成的链接，以便稍后通过超链接对象的添加功能将其绑定到所需的位置？

Answer 1

要查找通过公式添加的所有超链接，您可以使用 VBA 中的查找功能。以下例程将遍历所有超链接公式并调用子例程“replaceHyperlink”：

Sub replaceHyperlinks(Optional ws As Worksheet = Nothing)
    If ws Is Nothing Then Set ws = ActiveSheet
    
    Dim firstHit As Range, hit As Range
    Set hit = ws.Cells.Find(What:="=Hyperlink", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    Do While Not hit Is Nothing
        Call replaceHyperlink(hit)
        Set hit = ws.Cells.FindNext(after:=hit)
    Loop
End Sub

现在有点棘手了，我们需要创建一个函数来从Hyperlink-formula 中获取地址（url）和文本。获取文本很容易，您可以使用Value2-property 获取它。对于地址，我想除了分析公式文本之外别无他法。以下例程针对 3 种简单情况执行此操作：
- url 用引号引起来 ("https\\www.stackoverflow.com")
- url 是单元格引用（指向同一张表），例如B2。
- url 是对另一张表的单元格引用（例如Sheet2!B2）

如果 url 本身是由公式创建的（例如 "https:\\" & B2），它将失败。

拥有 URL 和文本，单元格的公式将被替换为文本并创建一个真正的超链接：

Sub replaceHyperlink(cell As Range)
    Const FormulaStart = "=HYPERLINK("
    If UCase(Left(cell.formula, Len(FormulaStart))) <> FormulaStart Then Exit Sub
    
    Dim formula As String, url As String, p As Long, text As String
    ' Search for the link address
    formula = Mid(cell.formula, Len("=Hyperlink(") + 1)
    p = InStr(formula, ",")
    If p > 0 Then
        formula = Left(formula, p - 1)
    Else
        formula = Left(formula, Len(formula) - 1)
    End If
    
    If Left(formula, 1) = """" And Right(formula, 1) = """" Then
        url = Mid(formula, 2, Len(formula) - 2)
    ElseIf InStr(formula, "!") = 0 Then
        url = cell.Parent.Range(formula)
    Else
        url = Evaluate(formula)
    End If
    
    text = cell.Value2
    cell.Value = text
    cell.Hyperlinks.Add Anchor:=cell, Address:=url, textToDisplay:=text
End Sub

更新 如果获取 url 的公式比较复杂，也许你可以把这个公式部分暂时写到单元格中。之后，Value2-property 应该将公式解析为 url。将最后几行替换为

text = cell.Value2            ' Save the friendly text
cell.formula = "=" & formula  ' Write the URL-part temporarily into cell as formula
url = cell.Value2             ' Get the result of that temp. formula 

cell.Value = text
cell.Hyperlinks.Add Anchor:=cell, Address:=url, textToDisplay:=text

Answer 2

我找到了一种方法来复制它，或者更确切地说是获取这种动态链接的地址。它在于必须将单元格复制到 Word （好开心——通过这个操作，Word 会计算出链接的实际地址并将其变成固定地址），然后检查 Word 对象的 Hyperlinks 集合已经

当然，在这种形式下它的工作速度很慢，但是如果你愿意，你可以改进它，例如，将 wdApp 对象设置为静态，而不是每次都创建/销毁它，这将大大加快工作速度，如果你需要处理很多单元格。

在 Excel/Word 2019 上测试（别忘了连接 Microsoft 对象库

Function GetLink(r As Long, c As Long) As String
    
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    If Cells(r, c).Value = Empty Then
      GetLink = ""
      Exit Function
    End If
    
    Cells(r, c).Copy
    
    Set wdApp = CreateObject("Word.Application")
    wdApp.Documents.Add
    Set wdDoc = wdApp.Documents(1)
    
    wdApp.Visible = False
    wdDoc.Range.PasteExcelTable False, False, False
    
    If wdDoc.Hyperlinks.Count = 0 Then
        GetLink = ""
      Else
        GetLink = wdDoc.Hyperlinks(1).Name
     End If
    wdDoc.Close (wdDoNotSaveChanges)
    wdApp.Quit (wdDoNotSaveChanges)
    
End Function