1 Sub ExcelToWord() ' 利用Word程序创建文本文件，运行时word不能为打开状态 2 3 Dim WordApp As Object 4 5 '搜索Dim Records As Integer, i As Integer 6 7 Dim Region As String, SalesAmt As String, SalesNum As String, strTitle As String 8 9 10 11 Set WordApp = CreateObject("Word.Application") '创建word对象 12 13 Records = Application.CountA(Sheets("sheet2").Range("A:A")) 'A列非空数据个数 14 15 16 17 WordApp.Documents.Add '新建文档 18 19 20 '写Title 21 22 strTitle = Cells(1, 5) 23 24 With WordApp.Selection 25 26 .Font.Size = 28 27 28 .ParagraphFormat.Alignment = 1 '左对齐0 居中1 右对齐2 29 30 .Font.Bold = True 31 32 .TypeText Text:=strTitle 33 34 .TypeParagraph 35 36 End With 37 38 39 40 '写内容 41 42 For i = 2 To Records + 1 43 44 'Region = Data.Cells(i, 1).Value '将第一列某行的值赋值给变量 45 46 Region = Cells(i, 1) 47 48 'SalesNum = Data.Cells(i, 2).Value '获取该行B列数据 49 50 SalesNum = Cells(i, 2) 51 52 'SalesAmt = Data.Cells(i, 3).Value '获取该行C列数据 53 54 SalesAmt = Cells(i, 3) 55 56 57 With WordApp.Selection 58 59 60 61 .Font.Size = 14 '设置字体字号 62 63 .Font.Bold = True '字体粗 64 65 .ParagraphFormat.Alignment = 0 '设置对齐 66 67 .TypeText Text:=Region & vbTab & SalesNum 68 69 ' .TypeParagraph 70 71 72 73 .Font.Size = 12 '设置字体 74 75 .ParagraphFormat.Alignment = 0 '设置对齐 76 77 .Font.Bold = False '字体不加粗 78 79 .TypeText Text:=vbTab & SalesAmt 80 81 .TypeParagraph '回车 82 83 .TypeParagraph '回车 84 85 86 End With 87 88 Next i 89 90 91 WordApp.ActiveDocument.SaveAs Filename:="AAA" '保存文件 92 93 WordApp.Quit '退出程序 94 95 Set WordApp = Nothing '清空 96 97 MsgBox "文件保存在我的文档底下的AAA文件" 98 99 End Sub
注意代码和数据源都在sheet2中。
若要改变保存word的路径（参考：http://club.excelhome.net/thread-1301171-1-1.html）：
1 Sub 联系的例子二() 2 Dim wd 3 Dim Arange 4 Set wd = CreateObject("word.application") '利用标识符启动WOrd wd.Visible = True’显示Word 5 wd.Documents.Open ("E:officeexcelExcelToWord.docx") '打开欲操作的对像 6 Arange = wd.Documents(1).Paragraphs(2).Range '取得要使用的文字 7 Workbooks("第三节.xlsm").Worksheets(1).Range("b8") = Arange '将文字写入相应单元格 Set wd = Nothing '终止两个程序间的联系 8 Set wd = Nothing '终止两个程序间的联系 9 End Sub 10 11 Sub ExcelToWord() ' 利用Word程序创建文本文件，运行时word不能为打开状态 12 13 Dim WordApp As Object 14 15 '搜索Dim Records As Integer, i As Integer 16 17 Dim Region As String, SalesAmt As String, SalesNum As String, strTitle As String 18 19 20 21 Set WordApp = CreateObject("Word.Application") '创建word对象 22 23 Records = Application.CountA(Sheets("sheet1").Range("A:A")) 'A列非空数据个数 24 25 26 27 WordApp.Documents.Add '新建文档 28 29 30 '写Title 31 32 strTitle = Cells(1, 5) 33 34 With WordApp.Selection 35 36 .Font.Size = 28 37 38 .ParagraphFormat.Alignment = 1 '左对齐0 居中1 右对齐2 39 40 .Font.Bold = True 41 42 .TypeText Text:=strTitle 43 44 .TypeParagraph 45 46 End With 47 48 49 50 '写内容 51 52 For i = 2 To Records + 1 53 54 'Region = Data.Cells(i, 1).Value '将第一列某行的值赋值给变量 55 56 Region = Cells(i, 1) 57 58 'SalesNum = Data.Cells(i, 2).Value '获取该行B列数据 59 60 SalesNum = Cells(i, 2) 61 62 'SalesAmt = Data.Cells(i, 3).Value '获取该行C列数据 63 64 SalesAmt = Cells(i, 3) 65 66 67 With WordApp.Selection 68 69 70 71 .Font.Size = 14 '设置字体字号 72 73 .Font.Bold = True '字体粗 74 75 .ParagraphFormat.Alignment = 0 '设置对齐 76 77 .TypeText Text:=Region & vbTab & SalesNum 78 79 ' .TypeParagraph 80 81 82 83 .Font.Size = 12 '设置字体 84 85 .ParagraphFormat.Alignment = 0 '设置对齐 86 87 .Font.Bold = False '字体不加粗 88 89 .TypeText Text:=vbTab & SalesAmt 90 91 .TypeParagraph '回车 92 93 .TypeParagraph '回车 94 95 96 End With 97 98 Next i 99 100 101 WordApp.ActiveDocument.SaveAs Filename:=ThisWorkbook.Path & "第三节" '按指定路径保存文件，此处为本excel路径 102 103 WordApp.Quit '退出程序 104 105 Set WordApp = Nothing '清空 106 107 MsgBox "文件保存在" & ThisWorkbook.Path & "下 第三节 文件" 108 109 End Sub