Copying table from Excel to Word bookmark using VBA code

[LadyTiara]

Hi ALL

I actually need your help on modifying this macro code. I got this code from somewhere else (sorry, forgot his name!). Basically, I have table data source from Sheet1 of excel. I need to transfer this table, keeping the formatting like borders, font size, auto fit, etc to MS Word with my bookmark named 'bookmark'.
Something to note:

1. Bookmark's location is at the VERY LAST PARAGRAPH. I have more than 12 paragraphs in my Word file but the table should be placed at the very last paragraph.
2. Please note the number of rows and columns in the table data source is dynamic. This means, the number of rows and columns are not fixed. It can change. My existing macro code works for this. However, it entirely deleted the existing paragraphs. The imported table replaced everything on my file.

Appreciate your help on item 2. Below is the code. Thank you very much in advance!


******************************
<>
Private Sub CommandButton1_Click()
On Error Resume Next

' FIRST GET THE ROWS COLUMNS OF A USED RANGE.

Dim iTotalRows As Integer ' GET TOTAL USED RANGE ROWS.
iTotalRows = Worksheets("sheet1").UsedRange.Rows.Count


Dim iTotalCols As Integer ' GET TOTAL COLUMNS.
iTotalCols = Worksheets("sheet1").UsedRange.Columns.Count



' WORD OBJECT.
Dim oWord As Object
Set oWord = CreateObject(Class:="Word.Application")
oWord.Visible = True
oWord.Activate

' ADD A DOCUMENT TO THE WORD OBJECT.
Dim oDoc
Set oDoc = oWord.Documents.Open("C:\Macro\samplebookmark1.docx")


' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Range


' CREATE AND DEFINE TABLE STRUCTURE USING
' THE ROWS AND COLUMNS EXTRACTED FROM EXCEL USED RANGE.
oDoc.Tables.Add oRange, iTotalRows, iTotalCols


' CREATE A TABLE OBJECT.
Dim oTable
Set oTable = oDoc.Tables(1)
oTable.Borders.Enable = True ' YES, WE WANT BORDERS.


Dim iRows, iCols As Integer


' LOOP THROUGH EACH ROW AND COLUMN TO EXTRACT DATA IN EXCEL.
For iRows = 1 To iTotalRows
For iCols = 1 To iTotalCols
Dim txt As Variant
txt = Worksheets("Sheet1").Cells(iRows, iCols)
oTable.cell(iRows, iCols).Range.Text = txt ' COPY (OR WRITE) DATA TO THE TABLE.


' BOLD HEADERS.
If Val(iRows) = 1 Then
objTable.cell(iRows, iCols).Range.Font.Bold = True
End If
Next iCols
Next iRows

Set oWord = Nothing
End Sub


<>

 

[LadyTiara]

I was able to figure it out by changing it to Set oRange = oDoc.Bookmarks("BookmarkName").Range.

And now this is my full macro. As you can see I am using mail merge. Even if there is a 'bookmark' in place, the newly saved file (because I'm using to call out a template) is not included. The table is missing. How can I correct it please?
Hope someone can assist me please! : Thank you!!
<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Private Sub CommandButton1_Click()
On Error Resume Next

' WORD OBJECT.
Dim i As Long, StrType As String, StrNm As String
Dim oWord As New Word.Application, oDoc As Word.Document
Const StrMMSrc As String = "C:\Macro\data2.xlsm"
oWord.DisplayAlerts = wdAlertsNone: oWord.Visible = True


' FIRST GET THE ROWS COLUMNS OF A USED RANGE.

Dim iTotalRows As Integer ' GET TOTAL USED RANGE ROWS.
iTotalRows = Worksheets("sheet1").UsedRange.Rows.Count

Dim iTotalCols As Integer ' GET TOTAL COLUMNS.
iTotalCols = Worksheets("sheet1").UsedRange.Columns.Count


' CREATE A RANGE FOR THE TABLE INSIDE WORD DOCUMENT.
Dim oRange
Set oRange = oDoc.Bookmarks("bookmark").Range

' CREATE AND DEFINE TABLE STRUCTURE USING
' THE ROWS AND COLUMNS EXTRACTED FROM EXCEL USED RANGE.
oDoc.Tables.Add oRange, iTotalRows, iTotalCols

' CREATE A TABLE OBJECT.
Dim oTable
Set oTable = oDoc.Tables(1)
oTable.Borders.Enable = True ' YES, WE WANT BORDERS.

Dim iRows, iCols As Integer

' LOOP THROUGH EACH ROW AND COLUMN TO EXTRACT DATA IN EXCEL.
For iRows = 1 To iTotalRows
For iCols = 1 To iTotalCols
Dim txt As Variant
txt = Worksheets("Sheet1").Cells(iRows, iCols)
oTable.cell(iRows, iCols).Range.Text = txt ' COPY (OR WRITE) DATA TO THE TABLE.

' BOLD HEADERS.
If Val(iRows) = 1 Then
objTable.cell(iRows, iCols).Range.Font.Bold = True
End If
Next iCols
Next iRows

i = 1
With Worksheets("Sheet1")
Do While .Range("g1").Offset(RowOffset:=i).Value <> ""
StrType = .Range("f1").Offset(RowOffset:=i).Value
StrNm = .Range("e1").Offset(RowOffset:=i).Value
'determine which template to use
If StrType = "FXD: Simple Barrier:FXD: Simple Option" Then
Set oDoc = oWord.Documents.Open(Filename:="C:\NDF Templates\Barrier and Vanilla Option.docx")

ElseIf StrType = "8" Then
Set oDoc = oWord.Documents.Open(Filename:="C:\Macro\samplebookmark1.docx")

Else
Set oDoc = oWord.Documents.Open(Filename:="C:\NDF Templates\Asian Option.docx")
End If

With oDoc
With .MailMerge
.OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
LinkToSource:=False, SQLStatement:="SELECT * FROM `Sheet1$`"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.ActiveRecord = i
.LastRecord = i
End With
.Execute Pause:=False
End With



'Save the confirmation
With ActiveDocument
.SaveAs2 Filename:="C:\Saved Templates" & StrNm & ".docx", _
FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=True, ReadOnlyRecommended:=True
'Close it
.Close False
End With
'Close it
.Close False
End With
i = i + 1
Loop
End With
oWord.DisplayAlerts = wdAlertsAll: oWord.Quit: Set oDoc = Nothing: Set oWord = Nothing
MsgBox "All done.", vbInformation, "Auto-production completed."
End Sub</code>