Transposing row from Excel into a Word Document Table - excel

Question

I have a database in Excel, each entry runs horizontally for 8 cells (A2:H10 for example).
I am trying to create Word documents enmasse from each 8 cell entry that inject vertically into a Word document table that is 8 cells total.
Here is an example of the code I have tried.
Sub CreateEntry()
Dim wdApp As Object
Dim wd As Object
Dim myarray As Variant
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set wd = wdApp.Documents.Add
wdApp.Visible = True
Sheets("Accommodation").Activate
Set Rng = ThisWorkbook.ActiveSheet.Range("A1:E76")
myarray = Range("A2:H2")
Range("A2:H2").Value = myarray
Range("A40:A48").Value = Application.WorksheetFunction.Transpose(myarray)
Set Rng = ThisWorkbook.ActiveSheet.Range("A40:A48")
Rng.Copy
With wd.Range
.Collapse Direction:=0
.InsertParagraphAfter
.Collapse Direction:=0
.PasteSpecial False, False, True
End With
End Sub

Answer 1

You can create tables directly in Word using the Word object model. That gives you more control over how it turns out.
Sub CreateEntry()
Dim doc As Object, rw As Range, tbl As Object
Dim n As Long
For Each rw In ThisWorkbook.Sheets("Accommodation").Range("A2:H3").Rows
Set doc = GetWordDoc()
Set tbl = doc.tables.Add(doc.Range, rw.Cells.Count, 1)
For n = 1 To rw.Cells.Count
tbl.Cell(n, 1).Range.Text = rw.Cells(n).Text
Next n
Next rw
End Sub
Function GetWordDoc() As Object
Dim wdApp As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
End If
On Error GoTo 0
Set GetWordDoc = wdApp.Documents.Add
End Function