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,

This is certainly progress!

It is copying all rows across to the Charts doc, making 91 pages in total!

Also, it is copying most of the data on the left hand side of the page instead of streatching it across the whole page width.

Does it make any difference that I am using Office 2003?

 

[Worf]

Hi
Sometimes different Office versions can cause some trouble; even prevent the macro from running, if a new method or property was added.
Anyway, please test the macro below, improved in the Word formatting department…
I didn't include the LastRow function, see previous posts.

Dim oWordDoc As Object, oWord As Object, nt%
Option Explicit

Sub E_W()
    
    PasteCharts
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts9.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%, LinNum%
    
    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
    
    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 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
    With oWordDoc.Tables(nt + 1)
        .PreferredWidthType = wdPreferredWidthPercent
        .PreferredWidth = 100
        .Columns(1).Width = 5           ' five percent of total
        .AutoFitBehavior (wdAutoFitWindow)
    End With
End Sub

Sub Data2Word()
    Dim i%, crow%, lr%, rng As Range
                  
    Sheets("Temp").Cells.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

 

[sharky12345]

Worf,

I'm afraid I'm really struggling with this - it now takes around 5 minutes with the egg timer waiting for the program to respond, it pastes all rows onto the document, (including the empty ones), and eventually gives me a run time error 5992 - "CANNOT ACCESS INDIVIDUAL COLUMNS IN THIS COLLECTION BECAUSE THE TABLE HAS MIXED CELL WIDTHS".

Any ideas?

 

[Worf]

Sometimes it’s not easy…

- Make a copy of your original document and delete most of the data rows, leave only a dozen or so. Like this you eliminate the size factor and we can concentrate on other problems for now.
- The Data2Word routine will only copy rows which have data on column A. Is this the right criteria?
- At the DataPaste routine, eliminate the columns(1).width line, it was just an example, and should take care of the error.

 

[sharky12345]

Worf,

I'll try what you've suggested and let you know.

So far as the data is concerned you are right - only rows with column A data need copying but the code you supplied copies all of it so I must be doing something wrong.

 

[sharky12345]

Worf,

Sorry chum - the problem persists and the program hangs for several minutes before pasting all rows onto the word document, even when I reduce the data down to 2 lines.

I've tried everything you suggested above so really don't know how else to proceed.

Only other thought is the amount of columns - can we specify which columns to copy to reduce the number?

 

[Worf]

I refuse to give up. Please test this modified version, based on your info.
Note that every code I post works for me, so it's frustrating...

Dim oWordDoc As Object, oWord As Object, nt%
Option Explicit

Sub E_W()
    
    PasteCharts
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts10.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%, 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 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
    With oWordDoc.Tables(nt + 1)
        .PreferredWidthType = wdPreferredWidthPercent
        .PreferredWidth = 100
        
        .AutoFitBehavior (wdAutoFitWindow)
    End With
End Sub

Sub Data2Word()
    Dim i%, crow%, lr%, rng As Range, t As Worksheet, d As Worksheet
    Set t = Sheets("Temp")
    Set d = Worksheets("Database")
    
    t.Cells.ClearContents
    lr = d.Range("a65536").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("a65536").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("a1:r" & crow)
    rng.HorizontalAlignment = xlCenter
    rng.Copy
        
End Sub

 

[sharky12345]

Worf,

Great news - that works, just needs some tweaking now, let me expand;

Rows 1 and 2 on the Database sheet are headers and the same is true for the Temp sheet which is identical in layout.

I want the headers to be copied onto the Word doc for presentation but not deleted or cleared from the sheet afterwards - the only data I need clearing is from row 3 onwards, (from the Temp sheet), at the end of the process so when the user checks the sheet the next time, the database sheet continues to accumulate data but the Temp sheet is clear.

Also, I probably don't need all columns copied across, only specific ones - is this possible?

If it is then that may cause another glitch, in that row 1 on the sheet is a merged cell and if only specific columns are copied across will that cause the header in row 1 to look 'squashed'? If so then I would probably just copy and paste row 2 only as a header.

Hopes this makes sense!

 

[Worf]

• Would you like headers at every Word page?
• Yes, it is possible to copy selected columns, tell me which ones to choose.
• Let’s see how the merged cell will react…

 

[sharky12345]

Hi Worf,

Yes please - I would like the headers on every page.

The columns I need are A, B, C, E, F, H, I, J, L, M, N, P, Q and R.

Thanks!