Fit large XL range to Word doc

Can't seem to Google up a working solution to paste and fit a large copied range from XL to a Word document. Here's my unsuccessful attempts. The WordApp is the active Word process. Any help welcomed. Dave

Code:

---

'WordApp.ActiveDocument.content.PasteSpecial Placement:=0 'wdInLine
    WordApp.ActiveDocument.content.Paste
    With WordApp.ActiveDocument
    .Range.autofitbehavior 2 'wdAutoFitWindow
    '.Range(0, .Characters.Count).autofitbehavior 2
    '.content.autofitbehavior 2
    End With

---

Not much luck with this one. I chased a solution down quite a few rabbit holes before arriving at a fairly simple solution which is to basically copy the XL range, paste it to the Word document as a table and then format the Word table. I've included some code to keep "chunks" of the XL range together if they cross 2 Word pages. The "chunks" of the range must be separated by a blank row in XL and custom styles must be added to the Word document. This section of code is commented out so just the basic range transfer and formatting will occur. To separate the "chunks", uncomment the relevant code (not the stuff with the '* in front of it), and add the custom styles to your document as indicated in the code. The font size may need to be changed if your range doesn't fit. Dave

Code:

---

Sub SaveXlRangeToWordFile2()
Dim Cnt As Integer, Last As Integer, Rng As Variant, WordTable As Object
Dim PFWdApp As Object, PagFlag As Boolean, Objtargetrange As Range, Lastrow As Integer
'set range to suit
With Sheets("Sheet1")
    Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set Objtargetrange = .Range(.Cells(1, "A"), .Cells(Lastrow, "G"))
End With


Objtargetrange.Copy


'open Word application
On Error Resume Next
Set PFWdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set PFWdApp = CreateObject("Word.Application")


'turn on pagination
If PFWdApp.Options.Pagination = False Then
PFWdApp.Options.Pagination = True
PagFlag = True
End If
End If


PFWdApp.Visible = True


On Error GoTo erfix
'set file path to suit
PFWdApp.Documents.Open Filename:="C:\TestFolder\test.docx", ReadOnly:=False
With PFWdApp.ActiveDocument
  .Range(0, .Characters.Count).Delete
End With


'paste XL range to word doc and make table
With PFWdApp.ActiveDocument
.paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
End With
Application.CutCopyMode = False


'****THIS SECTION TO KEEP "CHUNKS" TOGETHER
'***REQUIRES CUSTOM STYLES ADDED TO WORD DOCUMENT
'*"KeepItTogether" style = Normal + Keep with Next, keep lines together
'*"KeepItTogether2" style = Normal + Space after: 24 pt, keep lines together


'*if XL range larger than 1 Word page.
'If PFWdApp.ActiveDocument.paragraphs(PFWdApp.ActiveDocument.content.paragraphs.Count - 1) _
            .Range.Information(3) > 1 Then
'Cnt = 1
'Last = PFWdApp.ActiveDocument.Tables(1).Rows.Count
'With PFWdApp.ActiveDocument
'*keep chunks together on same page
'Do While Cnt <= Last
'*error generated when XL cell contents > 1 cell
'On Error Resume Next
'Set Rng = .Range(Start:=.Tables(1).Cell(Cnt, 1).Range.Start, _
          End:=.Tables(1).Cell(Cnt, .Tables(1).Columns.Count).Range.End)
'If Len(Rng.Text) <> .Tables(1).Columns.Count * 2 Then
'*not blank row
'Rng.Style = "KeepItTogether"
'Cnt = Cnt + 1
'Else
'*blank row
'*remove blank row. Reset previous row to "KeepItTogether2"
'*removes keep with next and adds blank row
'Rng.Range.Delete
'Set Rng = .Range(Start:=.Tables(1).Cell(Cnt - 1, 1).Range.Start, _
          End:=.Tables(1).Cell(Cnt - 1, .Tables(1).Columns.Count).Range.End)
'Rng.Style = "KeepItTogether2"
'Cnt = Cnt + 1
'End If
'*rng has contents
'If Err.Number <> 0 Then
'Err.Clear
'Rng.Style = "KeepItTogether"
'End If
'Set Rng = Nothing
'Loop
'End With
'End If ' more than 1 page


On Error GoTo erfix
'format Word table
Set WordTable = PFWdApp.ActiveDocument.Tables(1)
With WordTable
'16 is gridformat number 1
.AutoFormat Format:=16, applyborders:=False
.AutoFitBehavior (2) 'size to window
.Range.Font.Size = 9
End With


'turn off pagination/clean up
If PagFlag Then
PFWdApp.Options.Pagination = False
End If
'PFWdApp.ActiveDocument.Close savechanges:=True
'PFWdApp.Quit
'Set PFWdApp = Nothing
Set WordTable = Nothing
MsgBox "Done"
Exit Sub


erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile2 error"
Set WordTable = Nothing
PFWdApp.ActiveDocument.Close savechanges:=True
PFWdApp.Quit
Set PFWdApp = Nothing
End Sub

---