Microsoft Office Forums - View Single Post - Importing number data from an Excel spreadsheet into a Word table

gmayor · 06-07-2017, 04:08 AM

These look like Bingo Cards?

I guess there are several ways to do this. One is to create an Excel macro (code below) which works in conjunction with a template that matches your table (attached). Edit the macro to show the path where you store this template. The macro runs through each row in the worksheet (starting at Row 1) and adds the values from columns C to R to the appropriate cells of the document, then adds the formatted table to the end of a second document based on the first. You should get two tables on each page of the document. If you want to change the size/format of the table/cells then do it in the attached document.

Code:

Option Explicit

Sub CreateCardDoc()
'Run this macro from Excel
'Graham Mayor - http://www.gmayor.com - Last updated - 07 Jun 2017 
Dim i As Integer, j As Integer
Dim k As Integer, m As Integer
Dim LastRow As Long
Dim xlSheet As Worksheet
Dim wdApp As Object
Dim wdDoc As Object
Dim wdCardDoc As Object
Dim oTable As Object
Const strPath As String = "C:\Path\Forums\"    'The path where the template is stored
Dim oRng As Object, oNewRng As Object
    Set xlSheet = ActiveSheet
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    Set wdCardDoc = wdApp.Documents.Open(FileName:=strPath & "CardTable.docx", AddToRecentFiles:=False)
    Set wdDoc = wdApp.Documents.Add(Template:=strPath & "CardTable.docx")
    wdDoc.Range.Text = ""

    Set oTable = wdCardDoc.Tables(1)
    With xlSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To LastRow    'If header row make that i = 2
            m = 3    'assumes the numbers start in column 'C'
            For k = 1 To 4
                For j = 1 To 7 Step 2
                    Set oRng = oTable.Cell(k, j).Range
                    oRng.End = oRng.End - 1
                    oRng.Text = .Cells(i, m)
                    m = m + 1
                Next j
            Next k
            Set oNewRng = wdDoc.Range
            oNewRng.collapse 0
            oNewRng.formattedtext = oTable.Range.formattedtext
            DoEvents
        Next i
    End With
    wdCardDoc.Close 0
End Sub