之前我们分享了一期小代码，内容是如何将word中表格的数据读入excel……
之后有朋友表示知道了，又问如何将excel中的数据写入word……
此时此刻，我再一次清醒的意识到，这世界上像我这样好的人已经不多了。勉强害羞脸……
举个例子还是。
下图是一张excel表。
再下图是word中的一张excel表
两张表一个处于excel，一个处于word，但求同存异有一个非常重要的共同点：
表的布局是一致的，标题的内容和位置一模一样，比如标题都处在第一行等。
示例动画如下：
在excel中使用以下小代码可以将excel中的数据写入word：
Sub ExcelTableToWord()
Dim WdApp As Object
Dim objTable As Object
Dim objDoc As Object
Dim strPath As String
Dim arr As Variant, brr As Variant
Dim k As Long, x As Long, y As Long
Dim i As Long, j As Long, Clny As Long
On Error Resume Next
Set WdApp = CreateObject("Word.Application")
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "Word文件", "*.doc*", 1
'只显示word文件
.AllowMultiSelect = False
'禁止多选文件
If .Show Then strPath = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arr = [a1].CurrentRegion
'excel表格数据读入数组arr
Set objDoc = WdApp.documents.Open(strPath)
'后台打开用户选定的word文档
For Each objTable In objDoc.tables
'遍历word中的表格
x = objTable.Rows.Count
y = objTable.Columns.Count
For j = 1 To y
'遍历表格的标题行，默认标题处于第一行
If Application.Clean(objTable.Cell(1, j).Range.Text) = arr(1, j) Then
'如果标题行一致，则将excel表数据写入word
For i = 2 To x
With objTable.Cell(i, j).Range
.Text = ""
.Text = arr(i, j)
End With
Next
End If
Next
Next
objDoc.Close True: WdApp.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objDoc = Nothing
Set WdApp = Nothing
MsgBox "处理完成。"
End Sub
小贴士：
某男和女朋友吵架冷战了，想和好，但她不理，于是给她支付宝转了520元，然后又转1314元。
不久她发来一条信息：有诚意的话，一句话不要分开两次说。。。
图文制作：看见星光
点击【阅读原文】，拼了！