VBA 把Excel的内容复制到Word的代码？ 在excel里通过vba打开word文件并打印？

正好前几天在研究从EXCEL数据导出到WORD中。源代玛整理如下，有一些路径，文件名等需要变更信息的相信你能看明白（已用粗体标识）。提供的只是一个初学者的思路，该代码还有很大可优化空间，因为生成WORD文件的时候估计每个要用3-5秒时间，批量生成时就很烦（批量生成就是用循环，文件名称可以使用时间戳 & 随机数 & 自定义名称,一定不能只用时间戳，因为一秒钟有的时候会抽疯循环两次以上，名称完全一致会报错滴）。

Dim MyExcel As Workbook '定义WORKBOOK变量

Set MyExcel = Workbooks("D:\你需要导出表的绝对路径")

Dim MyWord As Object '定义变量

Dim MyArray '定义数组变量

Dim MyString as String

MyArray = MyExcel.Sheets("工作表名称").Range("A2:E2").Value '需要从EXCEL中导出的内容放到数组中，因为操作数组比直接调用RANGE要快得多。

Set MyWord = CreateObject("Word.Application") '生成WORD对象

MyString = MyArray1(1, 1) '通过操作数组给变量赋值，可以通过循环给多个变量赋值。

MyFileName = "生成WORD名称名" '文件名称

MyWord.documents.Add '新建文件

MyWord.documents(1).Range.InsertAfter MyString '往WORD内写入数据

fn = "D:\" & MyFileName '生成文件名

MyWord.documents(1).SaveAs fn '另存文件

MyWord.Close False '不保存关闭文件

MyWord.Quit False

Set MyWord = Nothing '清空变量

Erase MyArray1 '注销数据

Sub Execl_to_Word()
Dim wordApp As Object, newdoc As Object
Dim lt(8) As Object
Dim rg_publishtime As Range
Dim curow As Long
Dim counter_i As Integer
Dim sign_II As Boolean, sign_III As Boolean, sign_IV As Boolean, sign_VII As Boolean, sign_VIII As Boolean
Rem 创建新的WORD应用程序并新建文档
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set newdoc = wordApp.documents.Add
Rem 设置页面布局
With newdoc.PageSetup
Rem 纸张方向
.Orientation = 0 'wdOrientPortrait
Rem 页边距
.TopMargin = Application.CentimetersToPoints(2)
.BottomMargin = Application.CentimetersToPoints(2)
.LeftMargin = Application.CentimetersToPoints(1.9)
.RightMargin = Application.CentimetersToPoints(1.9)
Rem 额外页边距（供装订）
.Gutter = Application.CentimetersToPoints(0)
Rem 页眉页脚
.HeaderDistance = Application.CentimetersToPoints(1.5)
.FooterDistance = Application.CentimetersToPoints(1.75)
Rem 纸张大小
.PageWidth = Application.CentimetersToPoints(21)
.PageHeight = Application.CentimetersToPoints(29.7)
Rem 分页符类型
.SectionStart = 0 'wdSectionContinuous
Rem 奇偶页页眉页脚是否不同
.OddAndEvenPagesHeaderFooter = False
Rem 首页页眉页脚是否不同
.DifferentFirstPageHeaderFooter = False
Rem 文本对齐方式
.VerticalAlignment = 0 'wdAlignVerticalTop
Rem 装订线位置
.GutterPos = 0 'wdGutterPosLeft
Rem 文档版式模式
.LayoutMode = 2 'wdLayoutModeLineGrid
End With
Rem 自定义列表样式
For counter_i = 1 To 8
Set lt(counter_i - 1) = newdoc.ListTemplates.Add
With lt(counter_i - 1).ListLevels(1)
Select Case counter_i
Case 1
.NumberFormat = "%1、"
.NumberStyle = 37 'wdListNumberStyleSimpChinNum1
.Font.Name = ""
Case 2
.NumberFormat = "(%1)"
.NumberStyle = 39 'wdListNumberStyleSimpChinNum3
.Font.Name = ""
Case 3
.NumberFormat = "%1."
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case 4
.NumberFormat = "%1)"
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case 5
.NumberFormat = ChrW(61656)
.NumberStyle = 23 'wdListNumberStyleBullet
.Font.Name = "wingdings"
Case 6
.NumberFormat = ChrW(61692)
.NumberStyle = 23 'wdListNumberStyleBullet
.Font.Name = "wingdings"
Case 7
.NumberFormat = "%1."
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case Else
.NumberFormat = "%1)"
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
End Select
.TrailingCharacter = 0 'wdTrailingTab
.NumberPosition = Application.CentimetersToPoints(0)
.Alignment = 0 'wdListLevelAlignLeft
.TextPosition = Application.CentimetersToPoints(0)
.ResetOnHigher = False '延续编号
End With
Next
sign_II = True
sign_III = True
sign_IV = True
sign_VII = True
sign_VIII = True
curow = 1
On Error Resume Next
Set rg_publishtime = Report.Range("A:A").Find("*发布日期*")
If rg_publishtime Is Nothing Then
MsgBox "未找到 *发布日期* 标识", vbOKOnly, "提示"
Exit Sub
End If
While curow <= rg_publishtime.Row + 1
If Report.Range("A" & curow).Value <> "" And Report.Range("A" & curow).Font.Color = RGB(0, 0, 0) Then
If Report.Range("A" & curow).Value = "表格" Then
Rem 复制表格区域
Report.Range(Report.Range("F" & curow), Report.Cells(curow + Report.Range("A" & curow).MergeArea.Rows.Count - 1, Range("F" & curow).Column + Report.Range("F" & curow).MergeArea.Columns.Count + tblc(Report.Range("F" & curow)) - 1)).Copy
Rem 粘贴到WORD里
newdoc.Paragraphs(newdoc.Paragraphs.Count).Range.pasteExceltable False, False, False
Rem 设置表格格式
With newdoc.Tables(newdoc.Tables.Count)
With .Range.Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
End With
.AutoFitBehavior (1) 'wdAutoFitContent
.AutoFitBehavior (2) 'wdAutoFitWindow
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = Application.CentimetersToPoints(0)
End With
Rem 增加一个新段落供后续粘贴使用
'newdoc.Paragraphs.Add
Rem 供后续粘贴使用的段落清除掉从上文继承的列表格式
newdoc.Paragraphs(newdoc.Paragraphs.Count).Range.ListFormat.RemoveNumbers
Rem 左对齐
newdoc.Paragraphs(newdoc.Paragraphs.Count).Alignment = 0 'wdAlignParagraphLeft
Else
With newdoc.Paragraphs(newdoc.Paragraphs.Count)
With .Range.Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
.Bold = Report.Range("F" & curow).Font.Bold
End With
Rem 为粘贴的段落内容设置列表样式
Select Case Report.Range("A" & curow).Value
Case "样式:一、"
.Range.ListFormat.ApplyListTemplate lt(0), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_II = False
Case "样式:(一)"
.Range.ListFormat.ApplyListTemplate lt(1), sign_II, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_II = True
sign_III = False
Case "样式:1."
.Range.ListFormat.ApplyListTemplate lt(2), sign_III, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_III = True
sign_IV = False
Case "样式:1)"
.Range.ListFormat.ApplyListTemplate lt(3), sign_IV, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_IV = True
Case "样式:≯"
.Range.ListFormat.ApplyListTemplate lt(4), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VII = False
sign_VIII = False
Case "样式:√"
.Range.ListFormat.ApplyListTemplate lt(5), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
Case "样式:≯1"
.Range.ListFormat.ApplyListTemplate lt(6), sign_VII, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VII = True
Case "样式:≯1)"
.Range.ListFormat.ApplyListTemplate lt(7), sign_VIII, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VIII = True
Case "正文"
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
Case "***标题***"
.Alignment = 1 '标题居中：wdAlignParagraphCenter
Case "***署名***"
.Alignment = 2 '署名右对齐：wdAlignParagraphRight
Case "*发布日期*"
.Range.ParagraphFormat.RightIndent = Application.CentimetersToPoints(0.75)
.Alignment = 2 '发布日期右对齐：wdAlignParagraphRight
Case Else
End Select
Rem 粘贴内容并设置所粘内容的格式
counter_i = 0
While Report.Range("F" & curow).Offset(0, counter_i).Value <> ""
Rem 粘贴内容
.Range.InsertAfter Report.Range("F" & curow).Offset(0, counter_i).Value
Rem 为粘贴内容设置字体格式
With newdoc.Range(.Range.End - 1 - Len(Report.Range("F" & curow).Offset(0, counter_i).Value), .Range.End - 1).Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
.Bold = Report.Range("F" & curow).Offset(0, counter_i).Font.Bold
End With
counter_i = counter_i + 1
Wend
Rem 增加一个新段落供后续粘贴使用
newdoc.Paragraphs.Add
Rem 供后续粘贴使用的段落清除掉从上文继承的列表格式
.Range.ListFormat.RemoveNumbers
Rem 左对齐
.Alignment = 0 'wdAlignParagraphLeft
.CharacterUnitLeftIndent = 0 '取消缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = 0 '悬挂缩进2字符
End With
End If
End If
Rem 定位下一粘贴内容所在单元格
curow = curow + Report.Range("A" & curow).MergeArea.Rows.Count
Wend
counter_i = MsgBox("导出成功！请问是否需要保存", vbYesNo, "恭喜！")
If counter_i = 6 Then
newdoc.SaveAs (ThisWorkbook.Path + "\" + Range("B1").Value + Range("B2").Value + "周报.docx")
End If
Rem 清理内存
For counter_i = 1 To 8
Set lt(counter_i - 1) = Nothing
Next
Set newdoc = Nothing
Set wordApp = Nothing
Set rg_publishtime = Nothing
curow = 0
counter_i = 0
sign_II = False
sign_III = False
sign_IV = False
sign_VII = False
sign_VIII = False
End Sub
Private Function tblc(ByRef rg As Range) As Long
Dim curg As Range
Set curg = rg.Offset(0, 1)
tblc = 0
While curg.Value <> ""
tblc = tblc + curg.MergeArea.Columns.Count
Set curg = curg.Offset(0, 1)
Wend
Set curg = Nothing
End Function

完整代码如下：

Public Sub 复制数据()

Dim myFile As String

Dim myRange As Range

Dim docApp As Word.Application

Dim docRange As Word.Range

Set myRange = Worksheets("Sheet1").UsedRange '指定要复制的区域

myRange.Copy

myFile = ThisWorkbook.Path & "\目标Word文档.docx" '指定Word文档

Set docApp = New Word.Application

docApp.Documents.Open myFile, Visible:=True

Set docRange =
docApp.ActiveDocument.Paragraphs(1).Range '指定复制位置

docRange.PasteExcelTable LinkedToExcel:=True, WordFormatting:=False, RTF:=True

docApp.Documents.Close

docApp.Quit

Set myRange = Nothing

Set docRange = Nothing

Set docApp = Nothing

End Sub

此代码似乎是为Microsoft Excel编写的VBA宏。它创建一个新的Microsoft Word实例，设置页面布局，并创建自定义列表样式。然后，它在活动工作表的a列中搜索特定的文本字符串，并将表数据复制到新的Microsoft Word文档中。
宏首先声明用于保存对象和值的变量，例如Microsoft Word应用程序、新文档和用于搜索特定字符串的范围对象。然后为新Word文档设置各种页面布局财产。
然后，宏使用循环创建自定义列表样式，每个样式都具有基于其相应case语句的唯一格式。
接下来，宏在活动工作表的a列中搜索特定字符串，并将范围对象设置到该位置。然后，它进入一个循环，将工作表中的表数据复制到新的Word文档中。
在循环过程中，宏会检查A列中的每个单元格中的文本字符串“表格”（中文意思是“表格”），并将相应的表格数据复制到新的Word文档中。然后，宏更新用于控制复制数据格式的各种变量。
最后，宏保存新的Word文档并退出。
This code appears to be a VBA macro written for Microsoft Excel. It creates a new instance of Microsoft Word, sets the page layout, and creates custom list styles. It then searches for a specific text string in column A of the active worksheet and copies table data into a new Microsoft Word document.
The macro begins by declaring variables to hold objects and values, such as the Microsoft Word application, a new document, and a range object to search for a specific string. It then sets various page layout properties for the new Word document.
The macro then creates custom list styles using a loop, with each style having a unique format based on its corresponding case statement.
Next, the macro searches for a specific string in column A of the active worksheet and sets the range object to that location. It then enters a loop to copy table data from the worksheet into the new Word document.
During the loop, the macro checks each cell in column A for the text string "表格" (which means "table" in Chinese) and copies the corresponding table data into the new Word document. The macro then updates various variables used to control the formatting of the copied data.
Finally, the macro saves the new Word document and exits.

正好前几天在研究从EXCEL数据导出到WORD中。源代玛整理如下，有一些路径，文件名等需要变更信息的相信你能看明白（已用粗体标识）。提供的只是一个初学者的思路，该代码还有很大可优化空间，因为生成WORD文件的时候估计每个要用3-5秒时间，批量生成时就很烦（批量生成就是用循环，文件名称可以使用时间戳 & 随机数 & 自定义名称,一定不能只用时间戳，因为一秒钟有的时候会抽疯循环两次以上，名称完全一致会报错滴）。Dim MyExcel As Workbook '定义WORKBOOK变量Set MyExcel = Workbooks("D:\你需要导出表的绝对路径")Dim MyWord As Object '定义变量Dim MyArray '定义数组变量Dim MyString as StringMyArray = ***.sheets("工作表名称").Range("A2:E2").Value '需要从EXCEL中导出的内容放到数组中，因为操作数组比直接调用RANGE要快得多。Set MyWord = CreateObject("***.application") '生成WORD对象MyString = MyArray1(1, 1) '通过操作数组给变量赋值，可以通过循环给多个变量赋值。MyFileName = "生成WORD名称名" '文件名称***.documents.Add '新建文件***.documents(1).***.insertafter MyString '往WORD内写入数据fn = "D:\" & MyFileName '生成文件名***.documents(1).SaveAs fn '另存文件***.close False '不保存关闭文件***.quit FalseSet MyWord = Nothing '清空变量Erase MyArray1 '注销数据

vba如何将excel单元格内容输出到word指定位置？~

功能上来说是可以实现的，关键是word指定的位置怎么能在vba让电脑识别你说的“指定位置”。然后把相应的数据写入word的文档中。VBA需要跨word、excel 2个应用程序传递数据。
方法一：在excel里编写一个程序段，打开本数据表，循环开始：步骤1，打开或新建一个word文档，把你说的指定位置找到，步骤2，把此位置内容改写为excel内想应的数据，步骤3，保存word文档退出；然后重复下一个数据，按上述步骤循环至结束。
也可以方法二：在word里编写程序，打开excel这个数据表，循环开始：步骤1，读取相应的数据到“指定位置”，步骤2，并另存为一个独立文件；然后重复读取下一个数据，继续重复上述步骤。

在EXcel的VB编辑器中插入一个模块，输入如下代码试试看。

Sub ExcelToWord()
Dim WordObject As Object '声明一个对象变量，这里即将声明为Word对象
On Error Resume Next
Set WordObject = CreateObject("Word.Application") '用set来创建Word对象，这里是运行Word程序，但未新建文档
WordObject.Visible = 0 '后台运行Word对象，只在任务管理器中存在WinWord.exe进程，但在任务栏上看不到word；如果为1或者True则可以看到word运行界面
WordObject.Documents.Add DocumentType:=wdNewBlankDocument '新建一word文档
'以下为获取Excel表格中的内容，准备把数据传送给Word,可以根据自己的实际需要定制代码，这里只是示例代码
Excel.Application.Sheets(1).Activate '切换当前电子表格的表1为当前激活表
Excel.Application.Sheets(1).UsedRange.Select '选中当前激活表的所有数据
Selection.Copy '将选中的区域进行复制
WordObject.Application.Activate '将后台运行的Word激活为当前窗口
WordObject.ActiveWindow.Selection.Paste '将刚才从Excel中复制进剪贴板中的内容粘贴进word中来
WordObject.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果
WordObject.ActiveDocument.SaveAs "D:emp\导出数据.doc" '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称
WordObject.Application.Quit '退出并关闭程序文档
Set WordObject = Nothing '释放对象
End Sub