如何將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元。

不久她發來一條信息：有誠意的話，一句話不要分開兩次說。。。

歡迎朋友們分享辦公技巧

投稿、提問郵箱：[e-mail]