使用 VBA 将 Excel 文件中的超链接添加到 Word 文档

Question

我正在尝试添加从 Excel 到 Word 的超链接。

我尝试了不同的锚点，包括 ChBridge 和“>”，但都出现错误。

另外，有没有办法结合单独的文本替换来整理代码？

对 ChBridge 的查找是一个 http:\ 地址，并且已经是一个超链接，尽管在替换文本时它不会通过。

Sub MailMerge()

Dim oWord As Object
Dim oSelection As Object
Dim D1Diff As Double
Dim Site, sAddr, ChBridge As String
    
Set WB = ThisWorkbook.Sheets(Sheets.Count)
Set Sett = ThisWorkbook.Sheets("Settings")
Set RT = ThisWorkbook.Sheets("Hiring Order")

LR = WB.Cells(WB.Rows.Count, "U").End(xlUp).Row
        
For B = 3 To LR Step 1

    Set oWord = CreateObject("Word.Application")
    oWord.Documents.Open "*File Location*"
    oWord.Visible = True

    oWord.ActiveDocument.SaveAs Filename:="Line " & B - 2 & ".docx",     FileFormat:=wdFormatXMLDocument

    'Site & Address Vlookup
    Site = RT.Range("B2")
    sAddr = Application.VLookup(Site, Sett.Range("D1:G3"), 4, 0)

    'Chime Bridge Vlookup
    ChBridge = Application.VLookup(Site, Sett.Range("D1:H3"), 5, 0)

    Set sel = oWord.Selection

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Chime Bridge Hyperlink>>"
            .Replacement.Text = ChBridge
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            .Hyperlinks.Add Anchor:=.Range, Address:=ChBridge
           sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Site>>"
            .Replacement.Text = Site
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Address & Post Code>> "
            .Replacement.Text = sAddr
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    oWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
    oWord.Quit

Next B

End Sub

Answer 1

我不了解所有的查找和替换，但这应该可以帮助您入门。

看看我是如何声明变量并为它们分配类型的。

另请参阅我如何指代应用程序及其对象

我用的是Early bound，所以需要添加对Word对象模型的引用（read this）

Sub MailMerge()
    
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Sheets(Sheets.Count)
    
    Dim settingsSheet As Worksheet
    Set settingsSheet = ThisWorkbook.Sheets("Settings")
    
    Dim hiringOrderSheet As Worksheet
    Set hiringOrderSheet = ThisWorkbook.Sheets("Hiring Order")
    
    Dim lastRow As Long
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "U").End(xlUp).Row
    
    Dim counter As Long
    For counter = 3 To lastRow Step 1
        
        Dim wordApp As Word.Application
        Set wordApp = Word.Application
        wordApp.Visible = True
        
        Dim wordDoc As Word.Document
        Set wordDoc = wordApp.Documents.Open("C:\Temp\test.docx")
        
        wordDoc.SaveAs Filename:="Line " & counter - 2 & ".docx", FileFormat:=wdFormatXMLDocument
        
        'Site & Address Vlookup
        Dim site As String
        site = hiringOrderSheet.Range("B2").Value
        
        Dim siteAddress As String
        siteAddress = Application.VLookup(site, settingsSheet.Range("D1:G3").Value, 4, 0)
        
        'Chime Bridge Vlookup
        Dim ChBridge As String
        ChBridge = Application.VLookup(site, settingsSheet.Range("D1:H3").Value, 5, 0)
        
        Dim wordContent As Word.Range
        
        Set wordContent = wordDoc.Content
        
        wordContent.Find.ClearFormatting
        wordContent.Find.Replacement.ClearFormatting
        
        With wordContent.Find
            .Text = "<<Chime Bridge Hyperlink>>"
            .Forward = True
            .Wrap = 1
            .Format = False
        End With
        
        wordContent.Find.Execute
        
        While wordContent.Find.Found
            wordContent.Hyperlinks.Add Anchor:=wordContent, Address:=ChBridge, TextToDisplay:=ChBridge
            wordContent.Find.Execute
        Wend
        
        wordDoc.Close SaveChanges:=wdDoNotSaveChanges
        wordApp.Quit
        
    Next counter

End Sub