Consulting

Results 1 to 2 of 2

Thread: Fit large XL range to Word doc

  1. #1
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    848
    Location

    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
    '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

  2. #2
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    848
    Location
    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
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •