[英]VBA excel - Data File from sheet to word document with hyperlink
[英]Adding a Hyperlink from an Excel file to a Word document using VBA
我正在尝试将 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
我不明白所有的查找和替换,但这应该让你开始。
看看我是如何声明变量并为它们分配类型的。
另请参阅我如何引用单词应用程序及其对象
我用的是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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.