使用 VBA 將 Excel 文件中的超鏈接添加到 Word 文檔

Question

我正在嘗試將 Excel 的超鏈接添加到 Word。

我嘗試了不同的錨點，包括 ChBridge 和“<< Chime Bridge Hyperlink >>”，但都出現了錯誤。

另外，有沒有辦法結合單獨的文本替換來整理代碼？

對 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 Object Model 的引用（閱讀這個）

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