How to integrate the excel range into one single table? - vba

Question

I have two ranges in the excel file .
(A79-I84) & (A90-I92)
I am now using the Excel.RANGE.copy. to copy the two tables and paste on the word file .
However , the two ranges become two separate tables and the original excel table format cannot inherit to the new word file .Also , some cells from the word report will be shown in two lines .
In conclusion , the format of the word report will be very messy .
How to integrate the two table into one table with good table format or alignments?
the new table will be generated like this :
(red pen = problems )
My codes:
Sub ExcelRangeToWord()
Dim tbl0 As Excel.RANGE
Dim tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
'Set tbl0 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
Set tbl = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
Set tbl2 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A90:I92")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Add
'Trigger copy separately for each table + paste for each table
tbl.Copy ' paste range1
myDoc.Paragraphs(1).RANGE.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=True, _
RTF:=False
'before that...
'...go to end of doc and add new paragraph
myDoc.Bookmarks("\EndOfDoc").RANGE.InsertParagraphAfter
tbl2.Copy 'paste range2
'Paste Table into MS Word last paragraph
myDoc.Paragraphs(myDoc.Paragraphs.Count).RANGE.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=True, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set WordTable = myDoc.Tables(1)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
new aftereffect

Answer 1

Try the following. Simply hide rows in between (which ever you don't want to see) and copy as one range to be from "A79:I92" and paste as a picture. Credit here (#sneep) for sub to resize image. Note this will resize all images but could be adapted to target just one.
Option Explicit
Sub ExcelRangeToWord()
Dim tbl0 As Excel.Range
Dim Tbl As Excel.Range
Dim tbl2 As Excel.Range
Dim wordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet2") ' Change e.g. sheet9.Name
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE
'Copy Range from Excel
'Set tbl0 = ws.RANGE("A78:I83")
Set Tbl = ws.Range("A78:I92")
' Set tbl2 = ws.Range("A90:I92")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set wordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If wordApp Is Nothing Then Set wordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
wordApp.Visible = True
wordApp.Activate
'Create a New Document
Set myDoc = wordApp.Documents.Add
'Trigger copy separately for each table + paste for each table
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wordApp.Selection.Paste
wordApp.Selection.TypeParagraph
wordApp.Selection.PageSetup.Orientation = wdOrientLandscape
resize_all_images_to_page_width myDoc
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Sub resize_all_images_to_page_width(myDoc As Document)
'https://blog.qiqitori.com/?p=115
Dim inline_shape As InlineShape
Dim percent As Double
For Each inline_shape In myDoc.InlineShapes
inline_shape.LockAspectRatio = msoFalse
inline_shape.ScaleWidth = 100
inline_shape.ScaleHeight = 100
percent = myDoc.PageSetup.TextColumns.Width / inline_shape.Width
inline_shape.ScaleWidth = percent * 100
inline_shape.ScaleHeight = percent * 100
Next
End Sub