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,

Sorry chum but I am struggling with this, don't feel too guilty though because you said you liked a challenge!

I can't work out the debug side of things and additionally, the charts are being pasted on top of each other on the left instead of side by side in the middle.

Would it help if I sent you a copy of the workbook?

 

[Worf]

Hi
The challenge goes on…

Maybe it’s time you send me a copy, as suggested. But remember that we can’t take our discussion off the forum; I’ll post my findings here. One thing that is bothering me is that you seem to be using Excel 03; sometimes the bugs are version-specific. Let’s see.

Do you use any virtual storage service like SkyDrive or DropBox?
Case Yes
Place the file there and send me the link.
Case No
Email me. You can get my address at this site clicking me / view public profile / contact info / download vCard.

 

[sharky12345]

Agreed!

I've sent you an email - many thanks!

 

[Worf]

the charts are being pasted on top of each other on the left instead of side by side in the middle.

Hi Sharky

Please describe the desired chart layout in the Word document.
How many charts per page?

 

[sharky12345]

Worf,

Thanks - there are 6 charts and I need them 4 to a page side by side and centered, (obviously page 2 will only have 2 Charts but that's ok).

Thanks again!

 

[Worf]

Hi
Please test the E_W macro, worked fine for me.
Now you want the data table at the end of the Word file, right?

Dim oWordDoc As Object, oWord As Object

Sub E_W()
    
    PasteIntoWord
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts5.doc", FileFormat:= _
        wdFormatDocument, LockComments:=False, _
        AddToRecentFiles:=True, EmbedTrueTypeFonts:=False
    
    Set oWordDoc = Nothing
    Set oWord = Nothing
    
End Sub
Sub PasteIntoWord()
    Dim sFile$, i%, j%, counter%, mt As Table, wr As Word.Range
    Dim tablen%, nc%
    
    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 nc Mod 4 = 0 Then
        nt = nc / 4             ' how many tables are needed
    Else                        ' four charts per page
        nt = (nc \ 4) + 1
    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

 

[sharky12345]

Worf,

Great - it's putting 2 charts on the first page and 4 on the second, can that be changed around?

You are right too - I do want the data table after the charts.

Thank you!

 

[Worf]

Hi

1. For six charts, my code creates two 2x2 tables in Word, placing 4 charts at the first table and 2 at the second. Probably what is happening is that the first table is breaking pages.
Note: when I tested it at my computer, I got 4 charts at the first Word page…
Can you adjust that manually after the file is created?

2. I will post the data section shortly.

 

[sharky12345]

Will do buddy - can sort that no problem!

 

[Worf]

Hi Sharky
Please test the complete version. I noticed that if the Word template has a few blank lines at the beginning, this will cause the first table to split. If you can adjust this kind of thing before or after the macro runs, it’s easier than doing with code.
The data table is 18 columns wide, a bit hard to fit properly at the page.

Dim oWordDoc As Object, oWord As Object

Sub E_W()
    
    PasteCharts
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts7.doc", FileFormat:= _
        wdFormatDocument, LockComments:=False
    Set oWordDoc = Nothing
    Set oWord = Nothing
    
End Sub
Sub PasteCharts()
    Dim sFile$, i%, j%, counter%, mt As Table, wr As Word.Range
    Dim tablen%, nc%
    
    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 nc Mod 4 = 0 Then
        nt = nc / 4             ' how many tables are needed
    Else                        ' four charts per page
        nt = (nc \ 4) + 1
    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 t As Word.Range, pn%, cn%
    
    Data2Word
    oWordDoc.Bookmarks("\EndofDoc").Select
    pn = oWord.Selection.Information(wdActiveEndPageNumber)
    Do
        oWord.Selection.TypeParagraph
        cn = oWord.Selection.Information(wdActiveEndPageNumber)
    Loop Until cn = pn + 1          ' goes to a new page
    Set t = oWord.Selection.Range
    t.Paste
End Sub

Sub Data2Word()
    Dim i%, crow%, lr%, rng As Range
                  
    Sheets("Temp").UsedRange.ClearContents
    lr = LastRow(ThisWorkbook.Name, "Database")
    If lr > 3000 Then lr = 3000
    For i = 3 To lr
        If Sheets("Database").Cells(i, 1).Value <> "" Then
            crow = LastRow(ThisWorkbook.Name, "Temp") + 1
            Sheets("Temp").Range("a" & crow & ":r" & crow).Value = _
            Sheets("Database").Range("a" & i & ":r" & i).Value
        End If
    Next
    Set rng = Sheets("Temp").UsedRange
    rng.HorizontalAlignment = xlCenter  'center align the data
    rng.Copy
        
End Sub

Public Function LastRow(wname$, which$) As Long
    Workbooks(wname).Sheets(which).Activate
    If WorksheetFunction.CountA(Cells) = 0 Then
        LastRow = 0
        Exit Function
    End If
    LastRow = Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
End Function