Excel与Word数据交互【带案例】

梧叶沙沙

自己遇到的一些实际例子，分享给大家。很多代码也是从论坛学习来的。

例子很基础，希望能抛砖引玉

主要涉及以下几个方面：

Excel与Word表格交互读取

Excel与Word图片的交互（批量导出Word图片）

Excel批量生成Word合同

Word VBA中的常用对象及一些常用代码：

①Excel读取Word数据的框架：

1. Sub 打开Word()
   
2.     Set doc = CreateObject("word.application")
   
3.     f = Dir(ThisWorkbook.Path & "\*.doc")
   
4.     Do While f <> ""
   
5.         Set wd = doc.documents.Open(ThisWorkbook.Path & "" & f)
   
6.         doc.Visible = True
   
7.        '对Word进行操作的具体数据
   
8.         f = Dir
   
9.         wd.Close False
   
10.     Loop
    
11.     doc.Quit
    
12.     MsgBox "完成！"
    
13. End Sub

复制代码

②Word VBA向word表格写数据：

如下图所示的数据，如果要用WordVBA写入数据，有两种方式。

1. Sub 第一种写入方法()
   
2.     Dim t As Table
   
3.         Set t = ActiveDocument.Tables(1)
   
4.         t.Cell(1, 1).Range = 1
   
5.         t.Cell(1, 2).Range = 2
   
6.         t.Cell(1, 3).Range = 3
   
7.         t.Cell(2, 1).Range = 4
   
8.         t.Cell(2, 2).Range = 5
   
9.         t.Cell(2, 3).Range = 6
   
10. End Sub
    
11. 
    
12. 
    
13. Sub 第二种写入方法()
    
14.     Set t = ActiveDocument.Tables(1).Range
    
15.     For i = 1 To t.Cells.Count
    
16.         t.Cells(i).Range = i
    
17.     Next
    
18. End Sub

复制代码

③Word VBA新建2行3列表格：

1. Sub 宏1()
   
2.     ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:=3
   
3.     Selection.Tables(1).Style = "网格型" '如果不表格样式，看不到边框。
   
4. End Sub

复制代码

④Excel导出Word图片：

1. Sub 复制到Excel后输出1()
   
2.     Dim Excel_Shape As Shape
   
3.     Dim i As Integer
   
4.     Dim Word, Myword As Object
   
5.     Set Word = CreateObject("word.application")
   
6.     Set Myword = Word.Documents.Open("C:\Users\Brildo\Desktop\test.doc")
   
7.     Word.Visible = True
   
8.     Application.DisplayAlerts = False '从doc到xls的复制过程可能会报错，故加此句
   
9.     For i = 1 To Myword.Shapes.Count
   
10.         Myword.Shapes(i).Select
    
11.         Word.Selection.Copy
    
12.         ActiveSheet.Cells(i, 1).Activate
    
13.         ActiveSheet.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
14.         Set Excel_Shape = ActiveSheet.Shapes(1) '因为当单个doc中存在图片量过多，均复制到xls中造成数据量过大，
    
15.         '这里采用了复制一个进入xls，再另存图片后，立即删除xls中的图片数据，所以遍历时，index永远是1
    
16.         Excel_Shape.ScaleHeight 1, True, msoScaleFromMiddle '调整图片大小为原始大小，不缩放
    
17.         Excel_Shape.ScaleWidth 1, True, msoScaleFromMiddle
    
18.         Excel_Shape.Copy
    
19.         With ActiveSheet.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
20.             .Paste
    
21.             .Export ThisWorkbook.Path & "" & i & ".jpg"
    
22.             .Parent.Delete '删除第二次复制产生的数据
    
23.         End With
    
24.         Excel_Shape.Delete '删除第一次复制产生的数据
    
25.     Next i
    
26. End Sub
    

复制代码

梧叶沙沙

3年的沉淀，总结了诸多案例，我把excel与Word交互做成了一系列插件。--Excel魔方
插件地址：https://www.vbashuo.top/exceltool


生成、提取，只要有规律的需求，基本都可以攻克。

梧叶沙沙

案例一：Excel提取Word表格简历

以下为Word简历表中的具体结构，需要批量提取到Excel中。这里面就是对Word VBA中的table对象进行的读取操作。

1. Sub 提取数据()
   
2. On Error Resume Next
   
3. N = 1
   
4. Set doc = CreateObject("word.application")
   
5. f = Dir(ThisWorkbook.Path & "\*.doc")
   
6. Do While f <> ""
   
7. N = N + 1
   
8. Set wd = doc.documents.Open(ThisWorkbook.Path & "" & f)
   
9. doc.Visible = True
   
10. With doc.documents(1).Tables(1)
    
11. Cells(N, 1) = l(.cell(1, 2).Range) '姓名
    
12. Cells(N, 2) = l(.cell(1, 4).Range) '性别
    
13. Cells(N, 3) = l(.cell(1, 6).Range) '年龄
    
14. Cells(N, 4) = l(.cell(2, 2).Range) '籍贯
    
15. Cells(N, 5) = l(.cell(2, 4).Range) '身份证号
    
16. End With
    
17. f = Dir
    
18. wd.Close False
    
19. Loop
    
20. doc.Quit
    
21. MsgBox "完成！"
    
22. End Sub
    
23. Function l(a)
    
24. l = Left(a, Len(a) - 2)
    
25. End Function

复制代码

案例二：Excel批量导出Word中的图片
批量导出各个Word文档中每个人的照片，以身份证号作为图片的名字。

1. Sub 导出Word图片()
   
2. Dim PathSht As String, wb As Workbook
   
3. Application.ScreenUpdating = False
   
4. For Each shp In ActiveSheet.Shapes '清除本表中的图片
   
5. shp.Delete
   
6. Next
   
7. With Application.FileDialog(msoFileDialogFolderPicker)
   
8. If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
   
9. End With
   
10. PathSht = PathSht & IIf(Right(PathSht, 1) = "", "", "")
    
11. myfile = PathSht & "保存图片"
    
12. fol = Dir(myfile, vbDirectory)
    
13. If fol = "" Then MkDir myfile '新建存储图片的路径
    
14. myname = Dir(PathSht & "*.doc*")
    
15. Call wd_pic(PathSht)
    
16. MsgBox "完成！"
    
17. Application.ScreenUpdating = True
    
18. End Sub
    
19. 
    
20. Sub wd_pic(p As String)
    
21. Set wordapp = CreateObject("word.application")
    
22. Set sht = ThisWorkbook.ActiveSheet
    
23. f = Dir(p & "*.doc*") '结合Do While循环获取Word文档
    
24. Do While f <> ""
    
25. Set WordDOC = wordapp.Documents.Open(p & f) '逐个打开Word文件
    
26. wordapp.Visible = True
    
27. shenfen_num = l(WordDOC.Tables(1).cell(7, 2).Range) '获取身份证号
    
28. For i = 1 To WordDOC.Shapes.Count '对文档中的图片进行遍历
    
29. WordDOC.Shapes(i).Select '选中图片
    
30. wordapp.Selection.Copy '复制图片。这里不能合并为一句，否则报错
    
31. sht.PasteSpecial Format:="图片(增强型图元文件)", Link:=False, DisplayAsIcon:=False
    
32. Set Excel_Shape = sht.Shapes(1) '因为当单个doc中存在图片量过多，均复制到xls中造成数据量过大，
    
33. Excel_Shape.ScaleHeight 1, True, msoScaleFromMiddle
    
34. Excel_Shape.ScaleWidth 1, True, msoScaleFromMiddle
    
35. '这里采用了复制一个进入xls，再另存图片后，立即删除xls中的图片数据，所以遍历时，index永远是1
    
36. Excel_Shape.Copy
    
37. With sht.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
    
38. .Parent.Select '64位必须加这句，否则导出后是空白图片
    
39. .Paste
    
40. .Export p & "保存图片" & shenfen_num & ".bmp"
    
41. .Parent.Delete '删除第二次复制产生的数据
    
42. End With
    
43. Excel_Shape.Delete '删除第一次复制产生的数据
    
44. Next i
    
45. WordDOC.Close '关闭当前Word文档
    
46. f = Dir
    
47. Loop
    
48. wordapp.Quit
    
49. End Sub
    
50. Function l(a) '清除Word表格中的不可见符号
    
51. l = WorksheetFunction.Clean(a)
    
52. End Function
    

复制代码

案例三：Excel批量生成Word合同Excel数据批量写入Word，生成合同文书。数据的对应关系如下图截图中所示。

代码思路我用流程图画了出来：（jiangxiaoyun推荐这种案例用域对象的方法，稍后研究下）

1. Sub 写入Word数据()
   
2. Application.ScreenUpdating = False
   
3. Set doc = CreateObject("word.application")
   
4. doc.Visible = True
   
5. kehu_row = ActiveSheet.Cells(Rows.Count, 3).End(3).Row '找到C列已使用的最大行号，客户名称所在列
   
6. For i = 2 To kehu_row '开始对C列进行循环
   
7. If Cells(i, 3) <> "" And Cells(i + 1, 3) = "" Then '当是最后一行的情况的时候
   
8. r = Cells(i, 3).End(xlDown).Row - 1 '获取第三列此时的最大行号-1
   
9. If r = Rows.Count - 1 And r <> Cells(i, 4).End(xlDown).Row - 1 Then '该客户有多个商品
   
10. r = Cells(i, 4).End(xlDown).Row '第四列已使用的最大行号赋值给r
    
11. ElseIf r = Rows.Count - 1 And r = Cells(i, 4).End(xlDown).Row - 1 Then '该客户只有一个商品
    
12. r = i
    
13. End If
    
14. Set wd = doc.Documents.Open(ThisWorkbook.Path & "\合同模板.docx")
    
15. With doc.Documents(1).Tables(1)
    
16. .Rows(2).Select
    
17. If r <> i Then doc.Selection.insertrowsbelow r - i '如果r<>i，也就是说，该客户不止一件商品，word表格插入行
    
18. For rr = 2 To r - i + 2 '开始往word表格中写入数据
    
19. .cell(rr, 1).Range = IIf(Cells(i + rr - 2, 5).Value = "", "", Cells(i + rr - 2, 5).Value)
    
20. .cell(rr, 2).Range = IIf(Cells(i + rr - 2, 6).Value = "", "", Cells(i + rr - 2, 6).Value)
    
21. .cell(rr, 3).Range = IIf(Cells(i + rr - 2, 7).Value = "", "", Cells(i + rr - 2, 7).Value)
    
22. .cell(rr, 4).Range = IIf(Cells(i + rr - 2, 8).Value = "", "", Cells(i + rr - 2, 8).Value)
    
23. .cell(rr, 5).Range = IIf(Cells(i + rr - 2, 9).Value = "", "", Cells(i + rr - 2, 9).Value)
    
24. .cell(rr, 6).Range = IIf(Cells(i + rr - 2, 10).Value = "", "", Cells(i + rr - 2, 10).Value)
    
25. .cell(rr, 7).Range = IIf(Cells(i + rr - 2, 11).Value = "", "", Cells(i + rr - 2, 11).Value)
    
26. .cell(rr, 8).Range = IIf(Cells(i + rr - 2, 12).Value = "", "", Cells(i + rr - 2, 12).Value & "％")
    
27. Next
    
28. .cell(rr, 2).Range = WorksheetFunction.Sum(Range(Cells(i, 8), Cells(r, 8)))
    
29. .cell(rr, 5).Range = WorksheetFunction.Sum(Range(Cells(i, 11), Cells(r, 11)))
    
30. End With
    
31. Set myrange = wd.Content
    
32. With doc.Selection '查找替换数据
    
33. .HomeKey Unit:=6
    
34. .Find.Execute ("日期数据1")
    
35. .Text = Cells(i, 1).Value
    
36. .HomeKey Unit:=6
    
37. .Find.Execute ("日期数据2")
    
38. .Text = Cells(i, 1).Value
    
39. .HomeKey Unit:=6
    
40. .Find.Execute ("需方数据")
    
41. .Text = Cells(i, 3).Value
    
42. .HomeKey Unit:=6
    
43. .Find.Execute ("总金额数据")
    
44. .Text = Cells(i, 13).Value
    
45. .HomeKey Unit:=6
    
46. .Find.Execute ("甲方数据1")
    
47. .Text = Cells(i, 3).Value
    
48. .HomeKey Unit:=6
    
49. .Find.Execute ("甲方数据2")
    
50. .Text = Cells(i, 3).Value
    
51. End With
    
52. doc.ActiveWindow.ActivePane.View.SeekView = 9 '查找替换页眉数据
    
53. doc.Selection.HomeKey Unit:=6
    
54. If doc.Selection.Find.Execute("合同编号数据") Then
    
55. doc.Selection.Text = Cells(i, 2).Value
    
56. End If
    
57. doc.Selection.Find.Execute Replace:=2
    
58. doc.Selection.HomeKey Unit:=6
    
59. fpath = ThisWorkbook.Path & "" & Cells(i, 2).Value & "静载合同.docx"
    
60. wd.SaveAs fpath
    
61. wd.Close False
    
62. ElseIf Cells(i, 3) <> "" And Cells(i + 1, 3) <> "" Then '当是中间行的情况的时候
    
63. Set wd = doc.Documents.Open(ThisWorkbook.Path & "\合同模板.docx")
    
64. With doc.Documents(1).Tables(1)
    
65. .cell(2, 1).Range = Cells(i, 5).Value
    
66. End With
    
67. Set myrange = wd.Content
    
68. With doc.Selection
    
69. .HomeKey Unit:=6
    
70. .Find.Execute ("日期数据1")
    
71. .Text = Cells(i, 1).Value
    
72. .HomeKey Unit:=6
    
73. .Find.Execute ("日期数据2")
    
74. .Text = Cells(i, 1).Value
    
75. .HomeKey Unit:=6
    
76. .Find.Execute ("需方数据")
    
77. .Text = Cells(i, 3).Value
    
78. .HomeKey Unit:=6
    
79. .Find.Execute ("总金额数据")
    
80. .Text = Cells(i, 13).Value
    
81. .HomeKey Unit:=6
    
82. .Find.Execute ("甲方数据1")
    
83. .Text = Cells(i, 3).Value
    
84. .HomeKey Unit:=6
    
85. .Find.Execute ("甲方数据2")
    
86. .Text = Cells(i, 3).Value
    
87. End With
    
88. doc.ActiveWindow.ActivePane.View.SeekView = 9
    
89. doc.Selection.HomeKey Unit:=6
    
90. If doc.Selection.Find.Execute("合同编号数据") Then
    
91. doc.Selection.Text = Cells(i, 2).Value
    
92. End If
    
93. doc.Selection.Find.Execute Replace:=2
    
94. doc.Selection.HomeKey Unit:=6
    
95. fpath = ThisWorkbook.Path & "" & Cells(i, 2).Value & "静载合同.docx"
    
96. wd.SaveAs fpath
    
97. wd.Close False
    
98. Else
    
99. End If
    
100. Next
     
101. doc.Quit
     
102. Application.ScreenUpdating = True
     
103. MsgBox "完成！"
     
104. End Sub
     

复制代码

未完待续......

欢迎大家下载案例和我讨论。

月关

谢谢老师分享

梧叶沙沙

月关 发表于 2019-11-6 13:05
谢谢老师分享

不客气的，取之于论坛，回馈于论坛。

专搞excel

真棒，感谢分享

blackttea1

谢谢分享，点个赞

梧叶沙沙

专搞excel 发表于 2019-11-6 14:27
真棒，感谢分享

不客气的，一块进步

梧叶沙沙

blackttea1 发表于 2019-11-6 14:52
谢谢分享，点个赞

欢迎补充！

opel-wong

留个记号，跟贴学习！

renkangjizhen

这正是我寻找了多年的知识！感谢楼主！