如何将Excel中的数据写入Word表?

之前我们分享了一期小代码，内容是如何将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元。不久她发来一条信息：有诚意的话，一句话不要分开两次说。。。

晚安。