如何用Excel表格替换Word中的文本?

Question

我正试图使用Word模板与VBA发送电子邮件。在模板的中间我添加了<<表在祝辞为文本。我想用Excel文件中的表格替换此文本。

我收到

运行时错误'13'

当涉及到

.Replacement.Text = Sheet1.Range("A24:F" & lr).SpecialCells(xlCellTypeVisible)

Sub SendMail()
Dim ol As Outlook.Application
Dim olm As Outlook.MailItem
Dim wd As Word.Application
Dim doc As Word.Document
Set ol = New Outlook.Application
Set olm = ol.CreateItem(olMailItem)

Set wd = New Word.Application
wd.Visible = True
Set doc = wd.Documents.Open("C:UserscampoalvDesktopUS-Dec.docx")
lr = Sheet1.Range("A" & Application.Rows.Count).End(xlUp).Row
With wd.Selection.Find
.Text = "<<Table>>"
.Replacement.Text = Sheet1.Range("A24:F" & lr).SpecialCells(xlCellTypeVisible)
.Execute Replace:=wdReplaceAll
End With

doc.Content.Copy

With olm
.Display
.To = ""
.Subject = "Test"

Set Editor = .GetInspector.WordEditor
Editor.Content.Paste
'.Send
End With
Set olm = Nothing
Application.DisplayAlerts = False
doc.Close SaveChanges:=False
Set doc = Nothing
wd.Quit
Set wd = Nothing
Application.DisplayAlerts = True

End Sub

Answer 1

您可以将范围复制到查找内容<<Table>>的Word文档中。像这样…

Sub SendMail()
On Error GoTo Err_
Dim Word      As Word.Application
Dim Document  As Word.Document

Set Word = New Word.Application
Set Document = Word.Documents.Add("C:UserscampoalvDesktopUS-Dec.docx")

With Document.Content
If .Find.Execute("<<Table>>") Then
Range("A24:F" & Range("A" & Rows.Count).End(xlUp).Row).Copy
.Paste
End If
End With

With New Outlook.Application
With .CreateItem(olMailItem)
.To = ""
.Subject = "Test"

With .GetInspector.WordEditor
Document.Content.Copy
.Content.Paste
End With

.Display
End With
End With

Word.Quit 0

Exit_:
Exit Sub
Err_:
If Not Word Is Nothing Then
If Not Word.Visible Then Word.Quit 0
End If
MsgBox Err.Number & ": " & Err.Description, vbCritical, "Error"
Resume Exit_
End Sub