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