Multiple Excel ranges to multiple Word tables.

[Frimousse]

Hi,

I have been surfing for days trying to see if I can find a solution for this: I have 4 different ranges in an excel spreadsheet (all on the same sheet). I need to copy the first 25 lines (by three columns) of these ranges into 4 different tables in the same page of a word document. The tables are all preformated, have 26 lines each (1 for header, rest for data) and 3 columns with different alignment in each column (Left, right, right). So far, I have been able to create a new Word file and pasted the content of my first range but the format is wrong (not a big deal I can fix that eventually - I hope). My real problem is how do I select a specific table in Word (note that there are 4 tables and the page has two columns, so two tables per column). Also for some reasons, my programs(trials) are not willing to open an existing file even though the path is right (according to the pop-up comments provided by the editor) - hence a new file is created. If I can just know how to explicitly select a particular table into a Word document, that would be a great step in figuring out how to paste the data into it. Thanks for reading.

[Frimousse]

Hi,

Just updating on the progress for this project. I have now figured out how to access the different tables with:

Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=1, Name:=""
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=2, Name:=""
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=3, Name:=""
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=4, Name:=""

I still need to pass the copied material to these selection and ensure the format is right. Thanks.

[Frimousse]

Me again,

my progress and code so far...

Sub TransferExcel2Word()

Dim rng(4) As Range 'Source ranges
Dim wdApp As New Word.Application 'a new instance of Word
Dim wdDoc As Word.Document 'Word document
Dim wtable As Word.Range 'tables in Word as a range
Dim myWordFile As String 'path to Word template
Dim i As Integer

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

'open a new word document from the template
Set wdDoc = wdApp.Documents.Add(myWordFile)

'loop to copy the ranges into word tables
For i = 0 To 3

'Selecting the ranges from the Excel file
Set rng(i) = Sheets("sheet2").Range(Cells(2 * i + 1, 6), Cells(2 * i + 3, 31))
rng(i).Copy 'copy the range

'accessing the tables into the word document

Set wtable = wdDoc.Content 'set the range in Word
wtable.Tables(i).Cell(2, 1).Select 'First cell where data should be copied

'DO THE COPYING HERE

Next i

'until now the Word app has been a background process
wdApp.Visible = True

'SAVE THE FILE IN A DIFFERENT FOLDER UNDER A NAME BASED ON THE DATE

wdApp.Activate


End Sub
Any help appreciated. Thanks

[Dave]

Did some Word table and XL stuff here that might help.
http://www.vbaexpress.com/forum/showthread.php?t=17784
Here's an untested trial. HTH. Dave


Sub TransferExcel2Word()
Dim rng(4) As Range 'Source ranges
Dim wdApp As Object, wdDoc As Object
Dim myWordFile As String 'path to Word template
Dim i As Integer

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

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
For i = 1 To 4

'Selecting the ranges from the Excel file
With Sheets("Sheet2")
Set rng(i) = .Range(Cells(2 * i + 1, 6), Cells(2 * i + 3, 31))
End With

With rng(i)
.CopyPicture
End With

'paste picture of range to table cell (2,1)
With wdDoc.Tables(i).Cell(2, 1).Range
.Paste
End With

With wdDoc.Tables(i)
.Columns.AutoFit
End With
Application.CutCopyMode = False

Next i
wdDoc.SaveAs "D:\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

[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((...


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

[Frimousse]

Sorry a little bit of a mix up here.

the format in a cell is row first and then column. So the cell format should be

rng = .Cells(r + 5, (4 * t) - c - 2)

but that still does not solve the problem that this "With" block is apparently not defined.

Thanks for any help.

[Frimousse]

Progressing a bit further! This is the latest. The following code works! BUT if you look at the line Set rng = .Range("A7") ' Cells(r+5, (4 * t) -c -2)) you will see that I managed to make it work with just one cell ("A7") but i need the proper syntax or object definition to make it work with the Cells method. Anybody can see the glitch? I am almost there...

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 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")
Set rng = .Range("a7") 'Cells(r + 5, (4 * t) - c - 2))
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.Text = rng
End With
Next c
Next r
Next t

'With wdDoc.Tables(t)
' .Columns.AutoFit
'End With

Application.CutCopyMode = False

wdDoc.SaveAs "C:\Users\Systeme\Documents\Work\*****\Daily\Europe" & Format(Date, "ddmmyy") '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


Thanks for reading

[Frimousse]

Me again. I have now been able to copy every cells exactly where they are supposed to be. Still one problem remains. In Excel, my column have numbers fixed with one decimal. When transfered to a table, the numbers are shown in full precision. How do I go about formatting them? For those interested, here is the working code.

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 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")
Set rng = .Range(Chr(60 + c + (4 * t)) & r + 5) 'Cells(r + 5, (4 * t) - c - 2))
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.Text = rng
End With
Next c
Next r
Next t

'With wdDoc.Tables(t)
' .Columns.AutoFit
'End With

Application.CutCopyMode = False

wdDoc.SaveAs "C:\Users\Systeme\Documents\Work\*****\Daily\Europe\Europe" & Format(Date, "ddmmyy") '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


Thanks for help if any.....

[Frimousse]

Almost done. The code works fine and I am just doing the last refinements. So far I managed to (1) paste the data where it should go, (2) save the file with a name related to the current date, (3) format the numbers to fixed with one decimal place. I have only one item left to do to finalize this project: columns 2 and 3 of the word tables have to be right aligned. I put a line in my code but this does not work. Apparently this method is not supported here. Anyone knows which method would work in this context?

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 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")
Set rng = .Range(Chr(60 + c + (4 * t)) & r + 5)
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.Text = Format(rng, "0.0")
'.Columns(2).ParagraphFormat.Alignment = wdAlignParagraphRight
End With

Next c
Next r
Next t

Application.CutCopyMode = False

wdDoc.SaveAs "C:\Users\Systeme\Documents\Work\*****\Daily\Europe\Europe" & Format(Date, "ddmmyy")
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


Help anyone?!?

[Dave]

Whoops...that .copy should have been .copypicture. My apologies. Here's some column alignment code...

With oWDBasic.ActiveDocument.tables(t)
.Columns.AutoFit
'.Rows.SetLeftIndent LeftIndent:=-57.6, RulerStyle:=False
'.Columns(3).SetWidth ColumnWidth:=153.3, RulerStyle:=False
'.Columns(4).SetWidth ColumnWidth:=144, RulerStyle:=False
End With

Here's a trial pasting to one cell tables . HTH. Dave

For t = 1 To 4 'Loop to cycle through the tables(ranges)
With Sheets("Sheet2")
Select Case Cnt
Case 1: Set Rng = .Range(.Cells(6, "A"), .Cells(31, "C"))
Case 2: Set Rng = .Range(.Cells(6, "E"), .Cells(31, "G"))
Case 3: Set Rng = .Range(.Cells(6, "I"), .Cells(31, "K"))
Case 4: Set Rng = .Range(.Cells(6, "M"), .Cells(31, "o"))
End Select
End With

Rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With wdDoc.tables(t).Cell(1, 1).Range
.Paste
End With
With wdDoc.tables(t)
.Columns.AutoFit
End With
Application.CutCopyMode = False
Next t