Sub PasteExcelDataToWord()
'声明变量
Dim MyRange As Range
Dim wd As Word.Application
Dim wdDoc As Word.Document
Dim WdRange As Word.Range
'复制区域
Set MyRange = Sheets("Data").Range("A1:E8")
MyRange.Copy
'打开Word文档
Set wd = New Word.Application
Set wdDoc = wd.Documents.Open(ThisWorkbook.Path &"\PasteTable.docx")
wd.Visible = True
'将光标移至书签位置
Set WdRange = wdDoc.Bookmarks("DataTable").Range
'删除旧表格粘贴新表格
On Error Resume Next
WdRange.Tables(1).Delete
WdRange.Paste
'调整列宽
WdRange.Tables(1).Columns.SetWidth _
(MyRange.Width / MyRange.Columns.Count), wdAdjustSameWidth
'重新插入书签
wdDoc.Bookmarks.Add "DataTable", WdRange
'保存并退出Word
wdDoc.Save
wd.Quit
'释放对象变量
Set wd = Nothing
Set wdDoc = Nothing
Set WdRange = Nothing
End Sub
Sub PasteExcelDataToWordPlus()
'声明变量
Dim MyRange As Range
Dim wd As Word.Application
Dim wdDoc As Word.Document
Dim WdRange As Word.Range
Dim i As Long
'打开Word文档
Set wd = New Word.Application
Set wdDoc = wd.Documents.Open(ThisWorkbook.Path &"\PasteTable.docx")
wd.Visible = True
On Error Resume Next
'遍历命名区域
'并将其数据复制到Word文档相应的书签位置
For i = 1 To 2
Set MyRange = Names("rang" & i).RefersToRange
MyRange.Copy
Set WdRange = wdDoc.Bookmarks("DataTable" & i).Range
WdRange.Tables(1).Delete
WdRange.Paste
'调整表格列宽
WdRange.Tables(1).Columns.SetWidth _
(450 / MyRange.Columns.Count), wdAdjustNone
'恢复书签
wdDoc.Bookmarks.Add "DataTable" & i, WdRange
Next i
'保存并关闭Word
wdDoc.Save
wd.Quit
'释放对象变量
Set wd = Nothing
Set wdDoc = Nothing
Set WdRange = Nothing
End Sub
Sub CopyDataToWord()
Dim wdApp As Word.Application
Dim myRange As Range
Dim i As Long
'建立与Word的连接
Set wdApp = New Word.Application
With wdApp
'打开Word文档
.Documents.Open Filename:=ThisWorkbook.Path &"\PasteTable.docx"
For i = 1 To 2
'复制相应区域的数据
Set myRange =Names("rang" & i).RefersToRange
myRange.Copy
With .Selection
'到文档末尾,添加新段落
.EndKey Unit:=wdStory
.TypeParagraph
'粘贴数据
.Paste
End With
Next i
'保存
.ActiveDocument.Save
'退出Word
.Quit
End With
'释放对象变量
Set wdApp = Nothing
End Sub