Copy used range to Word

[sharky12345]

I've managed to get hold of the following code that will copy the values from a range and paste them to a Word document, what I need to do if possible is only copy the rows that have data in column A.

Additionally, the code should only copy across to column R - so to summarise, copy ALL columns from A to R and only if A has data in it, (starting at A2).

Is it possible?

Option Explicit
Sub Data2Word()
'Remember: this code requires a referece to the Word object model
    'dimension some local variables
    Dim rng As Range                    'our source range
    Dim wdApp As New Word.Application   'a new instance of Word
    Dim wdDoc As Word.Document          'our new Word document
    Dim t As Word.Range                 'the new table in Word as a range
    Dim myWordFile As String            'path to Word template
 
 
    'initialize the Word template path
    'here, it's set to be in the same directory as our source workbook
    myWordFile = ThisWorkbook.Path & "\DocWithTableStyle.dot"
 
    'get the range of the contiguous data from Cell A1
    Set rng = Range("A2").CurrentRegion
    'you can do some pre-formatting with the range here
    rng.HorizontalAlignment = xlCenter  'center align the data
    rng.Copy                            'copy the range
 
    'open a new word document from the template
    Set wdDoc = wdApp.Documents.Add(myWordFile)
 
    Set t = wdDoc.Content               'set the range in Word
    t.Paste                             'paste in the table
    With t                              'working with the table range
        .Style = "GreenBar"             'set the style created for the table
        'we can use the range object to do some more formatting
        'here, I'm matching the table with using the Excel range's properties
        .Tables(1).Columns.SetWidth (rng.Width / rng.Columns.Count), wdAdjustSameWidth
    End With
 
    'until now the Word app has been a background process
    wdApp.Visible = True
    'we could use the Word app object to finish off
    'you may also want to things like generate a filename and save the file
    wdApp.Activate
End Sub

 

[sharky12345]

Worf,

Additionally, I need the gridlines to be shown on the word doc, (they are not on the spreadsheet which is correct).

 

[Worf]

Hi Sharky

Please test this new version of the Excel - Word automation.
I didn't include the first Database header row because it was eating up much space.
This is guaranteed to work with Office 2007...

Option Explicit
Option Base 1
Dim oWordDoc As Object, oWord As Object, nt%, d As Worksheet, t As Worksheet, cw!(14)

Sub E_W()
    Dim ca, i%
    ca = Array("d", "g", "k", "o")  ' unwanted columns
    Set d = Worksheets("Database")
    Set t = Sheets("Temp")
    For i = 1 To 4
        d.Columns(ca(i)).Hidden = True
        t.Columns(ca(i)).Hidden = True
    Next
    PasteCharts
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts11.doc", FileFormat:= _
        wdFormatDocument, LockComments:=False
    oWord.Visible = True
    Set oWordDoc = Nothing
    Set oWord = Nothing
    For i = 1 To 4
        d.Columns(ca(i)).Hidden = False
        t.Columns(ca(i)).Hidden = False
    Next
End Sub

Sub PasteCharts()
    Dim sFile$, i%, j%, counter%, mt As Table, wr As Word.Range
    Dim tablen%, nc%, LinNum%, au%
    
    sFile = ThisWorkbook.Path & "\Charts.dot"
    On Error Resume Next
    Set oWord = GetObject(, "Word.Application")
    If Err <> 0 Then Set oWord = CreateObject("Word.Application")
    Err.Clear
    On Error GoTo Err_Handler
    nc = Sheets("Stats").ChartObjects.Count
    Set oWordDoc = oWord.Documents.Open(sFile)
    oWord.Visible = True
    oWordDoc.Activate
    If oWordDoc.Tables.Count > 0 Then
        Do
            au = oWordDoc.Tables.Count
            oWordDoc.Tables(au).Delete
        Loop Until au = 1
    End If
    If nc Mod 4 = 0 Then
        nt = nc / 4             ' how many tables are needed
    Else                        ' four charts per page
        nt = (nc \ 4) + 1
    End If
    
    oWord.Selection.EndKey Unit:=wdStory
    Set wr = oWord.Selection.Range
    LinNum = wr.Information(wdFirstCharacterLineNumber)
    If LinNum > 2 Then
        Do              ' eliminate extra lines at the beginning
            wr.Delete
            LinNum = wr.Information(wdFirstCharacterLineNumber)
        Loop Until LinNum = 2
    End If
    For i = 1 To nt
        Set wr = oWordDoc.Range
        With wr
            .Collapse Direction:=wdCollapseEnd
            .InsertParagraphAfter
            .Collapse Direction:=wdCollapseEnd
        End With
        Set mt = oWordDoc.Tables.Add(Range:=wr, NumRows:=2, NumColumns:=2)
    Next
    counter = 1
    tablen = 1
    Do
        For i = 1 To 2
            For j = 1 To 2
                Sheets("Stats").ChartObjects(counter).CopyPicture
                oWordDoc.Tables(tablen).Cell(i, j).Range.Paste
                If counter = nc Then Exit Do
                If counter Mod 4 = 0 Then tablen = tablen + 1
                counter = counter + 1
            Next
        Next
    Loop Until counter = nc + 1
    Exit Sub
Err_Handler:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume Next
End Sub
    
Sub DataPaste()
    Dim pn%, cn%, i%, j%, ht As Word.Table, av%, dt As Word.Table, totchars!, netw!
            
    netw = oWordDoc.ActiveWindow.Panes(1).Pages.Item(1).Width - _
    oWordDoc.PageSetup.LeftMargin - oWordDoc.PageSetup.RightMargin  ' usable width
    oWord.Visible = False
    oWordDoc.Bookmarks("\EndofDoc").Select
    oWord.Selection.Range.InsertBreak Type:=wdSectionBreakNextPage
    oWordDoc.Sections(2).Headers(wdHeaderFooterPrimary).LinkToPrevious = False
    t.Range("a2:r2").Copy
    oWordDoc.Sections(2).Headers(wdHeaderFooterPrimary).Range.Paste
    Data2Word
    
    oWordDoc.Bookmarks("\EndofDoc").Select
    oWord.Selection.Range.Paste
    Set dt = oWordDoc.Tables(nt + 1)
    Set ht = oWordDoc.Sections(2).Headers(wdHeaderFooterPrimary).Range.Tables(1)
    For i = 1 To 14
        cw(i) = ht.Cell(1, i).Range.Characters.Count
    Next
    totchars = 0
    For i = 1 To 14         ' all columns
        For j = 1 To 10     ' decides table width based on the first ten records
            av = dt.Cell(j, i).Range.Characters.Count
            If av > cw(i) Then cw(i) = av
        Next
        totchars = totchars + cw(i)
    Next
        
    For i = 1 To 14
        cw(i) = cw(i) * netw / totchars
    Next
    Formatter dt
    Formatter ht
    For i = -6 To -1        ' all the borders
        With oWordDoc.Tables(nt + 1).Borders(i)
            .LineStyle = Options.DefaultBorderLineStyle
            .LineWidth = Options.DefaultBorderLineWidth
            .Color = Options.DefaultBorderColor
        End With
    Next
End Sub

Sub Formatter(wt As Word.Table)
    Dim i%, j%
    With wt
        .AllowAutoFit = False
        For i = 1 To 14
            .Columns(i).Width = cw(i)   ' same values for header
        Next                            ' and data table
    End With
    For i = 1 To wt.Rows.Count
        For j = 1 To wt.Columns.Count
            wt.Cell(i, j).Range.Font.Size = 9
            wt.Cell(i, j).Range.Font.Name = "Arial"
        Next
    Next
End Sub

Sub Data2Word()
    Dim i%, crow%, lr%, rng As Range
    
    lr = t.Range("a" & Rows.Count).End(xlUp).Row
    t.Range(Cells(3, 1).Address, Cells(lr, Columns.Count).Address).ClearContents
    lr = d.Range("a" & Rows.Count).End(xlUp).Row
    If lr > 3000 Then lr = 3000
    For i = 3 To lr
        d.Cells(i, 1).Value = Trim(d.Cells(i, 1).Value)
    Next
    For i = 3 To lr
        If d.Cells(i, 1).Value <> "" Then
            crow = t.Range("a" & Rows.Count).End(xlUp).Row + 1
            t.Range("a" & crow & ":r" & crow).Value = _
            d.Range("a" & i & ":r" & i).Value
        End If
    Next
    Set rng = t.Range("a3:r" & crow)
    rng.HorizontalAlignment = xlCenter
    rng.Copy
        
End Sub

 

[sharky12345]

Worf,

That works!

There is just one last tweak needed to perfect the final look and that is can we set the font size on the word doc to be '8' automatically?

As it is, it's set to 9 which is slightly too big for me.

Thank you!

 

[Worf]

This one you can fix yourself: go to the Formatter routine and change the font size to 8...

 

[sharky12345]

Brilliant - thank you so much for all your help!

 

[Worf]

You are welcome.

It was a good opportunity to improve my Word skills...

 

[NdNoviceHlp]

This has been an interesting thread to follow. The helpful persistance to a succesful outcome was inspiring. I thought that I would hopefully add to your learning that there is a binding thing and reference thing that affects the transportbility of your workbook. If you use late binding (which you are) then you don't need to set a reference to the Word object library. However, without the reference set then you can't use Word VBA references such as wdCollapseEnd... but you can replace these with constants ie. wdCollapseEnd = 0 (which Google readily supplies). I'm also against setting the application to visible and then letting the user get rid of the objects and application that you created. I would save your changes and then re-open the file for viewing... but whatever works is also good. Going to time out... HTH. Dave

 

[Worf]

Hello Dave

Thanks for the comments. I believe named constants make the code easier to understand.
xlIWillDrawRedLinesIfIFeelLikeDoingSo is more meaningful than just '4', right?

Here's some stuff for meditation, there is no perfect solution...

Early binding (dim x as Areferenced.ObjectType) is generally considered better than late binding (dim x as object; x= CreateObject(“AnUnreferenced.ObjectType”)

Here are the main reasons why:

you get intellisense (usually)
you get much compile time checking
its faster than late binding
(do you have any others?)

There is one down side which people often skip over:
if the correct version of the referenced component isn’t registered on the client pc, VBA will fail to compile let alone run, with the classic “Cannot find project or library” error.
How many times have you had to talk a user through opening the VBIDE and checking Refererences for #Missing ones?
This is the main reason we are advised to develop on the oldest version we intend to support. Most components seem to upgrade to a newer version fine, very few seem to down grade to work with an older version.