Multiple Excel ranges to multiple Word tables.

[Frimousse]

Hi Dave,

your code works but it doesn't give the intended results . It takes a picture of the sheet and copy the same thing on each cell (2,1) of every table. This is what I came up with now but I am having some sort of syntax error somewhere in there. I am getting: Object variable or With block variable not set on the line rng = .Cells((...

[VBA]
Sub TransferExcelToWord()
Dim rng As Range 'Source ranges
Dim wdApp As Object, wdDoc As Object
Dim myWordFile As String 'path to Word template
Dim t, r, c As Integer

'initializing the template located in same directory
myWordFile = ThisWorkbook.Path & "\test3.dotx"

On Error GoTo ErrFix
Set wdApp = CreateObject("Word.Application")
'open a new word document from the template
Set wdDoc = wdApp.Documents.Add(myWordFile)

'loop to copy the ranges into word tables
'although not elegant, I resorted to copy and paste every single cell one by one
' there are 4 ranges on a sheet: A6:C31, E6:G31, I6:K31, M6:o31
For t = 1 To 4 'Loop to cycle through the tables(ranges)
For r = 1 To 25 'loop to cycle through the rows
For c = 1 To 3 ' loop to cycle through the columns
'Selecting the ranges from the Excel file

With Sheets("Sheet2")
rng = .Cells((4 * t) - c - 2, r + 5)
End With

With rng
.Copy
End With

'paste the cell to the appropriate table in word
'begin with cell (2,1) to preserve the headers
With wdDoc.Tables(t).Cell(r + 1, c).Range
.Paste
End With
Next c
Next r
Next t

With wdDoc.Tables(i)
.Columns.AutoFit
End With

Application.CutCopyMode = False

wdDoc.SaveAs "C:\Users\System\Documents\Work\TEST1.DOC" 'change to suit
wdDoc.Close savechanges:=False
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
MsgBox "Finished"
Exit Sub


ErrFix:
On Error GoTo 0
MsgBox "Error"
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
[/VBA]