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

 

[Worf]

Hello

The following code will do what you asked for. A few points to note:

1. I didn't test it with a template, rather a doc file.

2. I assumed the data resides in "Sheet1"

3. You need a "Temp" sheet for intermediate data storage

This example can be adjusted to suit your exact needs...

Sub Data2Word()
'Remember: this code requires a referece to the Word object model
    'dimension some local variables
    Dim rng As Range, i%, crow%
    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
     
    myWordFile = ThisWorkbook.Path & "\Main2.docx"
 
    Sheets("Temp").UsedRange.ClearContents
    For i = 2 To LastRow(ThisWorkbook.Name, "Sheet1")
        If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
            crow = LastRow(ThisWorkbook.Name, "Temp") + 1
            Sheets("Temp").Range("a" & crow & ":r" & crow).Value = _
            Sheets("Sheet1").Range("a" & i & ":r" & i).Value
        End If
    Next
    Set rng = Sheets("Temp").UsedRange
    'you can do some pre-formatting with the range here
    rng.HorizontalAlignment = xlCenter  'center align the data
    rng.Copy                            'copy the range
 
    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
            
        .Tables(1).Columns.SetWidth (rng.Width / rng.Columns.Count), wdAdjustSameWidth
    End With
    wdApp.Visible = True
    wdApp.Activate
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

 

[sharky12345]

Worf,

Thank you for that - very helpful, but I've moved on a little with the project and now need to amend this slightly, I was wondering if you can advise on the following?

I have the code below which collects the charts from the workbook and pastes them into a Word document. Can my code be adjust to put the other data, (from the Database sheet as described above), to a bookmark at the end of the Word document so I have one document with the charts first then the actual data?

Option Explicit
Sub test()
    PasteIntoWordDocument "Chart 3"
    PasteIntoWordDocument "Chart 2"
    PasteIntoWordDocument "Chart 5"
    PasteIntoWordDocument "Chart 15"
    PasteIntoWordDocument "Chart 6"
    PasteIntoWordDocument "Chart 1"
 
End Sub
Sub PasteIntoWordDocument(sname)
    Const wdPasteMetafilePicture = 3
    Dim oWord As Object
    Dim oWordDoc As Object
    Dim sFile
    Dim sBMname
    Dim bMark
    Dim iline
    '------------------------------------------
    ' set path/filename to Word doc with bookmarks
    sFile = "C:\Users\Paul\Desktop\Test\Charts.dot"
    '------------------------------------------
    ' Make sure document is their
    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
    '------------------------------------------
    ' Copy chart
    ActiveSheet.ChartObjects(sname).Copy
    '------------------------------------------
    ' open documenr
     Set oWordDoc = oWord.Documents.Open(sFile)
    oWord.Visible = True
    '------------------------------------------
    ' Set up Boomark name
    sBMname = Replace(sname, " ", "_")
    '------------------------------------------
    ' Get to bookmark
    oWordDoc.Activate
    Set bMark = oWord.ActiveDocument.Bookmarks(sBMname)
    bMark.Select
    iline = bMark.Start
    '------------------------------------------
    '  Pasre at bookmark location
    oWord.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
    Placement:=bMark.Start, DisplayAsIcon:=False
    '------------------------------------------
    '  TA Da!
    Set oWordDoc = Nothing
    Set oWord = Nothing
    Set bMark = Nothing
Exit Sub
Err_Handler:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume Next
End Sub

Additionally, if it can be done, I then want that document to be saved as a .doc rather than messing around with the template itself.

Am I asking too much?

 

[Worf]

Am I asking too much?

Not at all, I like some challenge...

Please test the code below, any doubts just say so.

Option Explicit
Dim rng As Range, oWordDoc As Object, oWord As Object, bMark

Sub test()
    PasteIntoWordDocument 1
    PasteIntoWordDocument 2
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"

    oWordDoc.SaveAs Filename:="Charts4.docx", FileFormat:= _
        wdFormatDocumentDefault, LockComments:=False, _
        AddToRecentFiles:=True, EmbedTrueTypeFonts:=False
    Set oWordDoc = Nothing
    Set oWord = Nothing
End Sub

Sub PasteIntoWordDocument(snumber%)
    Const wdPasteMetafilePicture = 3
    Dim sFile$, sBMname$, i%
        
    sFile = ThisWorkbook.Path & "\Charts.dotm"
    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
    '------------------------------------------
    Sheets("Control").ChartObjects(snumber).Copy
    '------------------------------------------
    Set oWordDoc = oWord.Documents.Open(sFile)
    oWord.Visible = True
    '------------------------------------------
    sBMname = "BM" & snumber
    '------------------------------------------
    oWordDoc.Activate
    oWord.Selection.EndKey unit:=wdStory
    While oWordDoc.Bookmarks.Count > 0
        oWordDoc.Bookmarks(oWordDoc.Bookmarks.Count).Delete
    Wend
    oWordDoc.Bookmarks.Add Name:=sBMname
    Set bMark = oWord.ActiveDocument.Bookmarks(sBMname)
    bMark.Select
    '------------------------------------------
    oWord.Selection.PasteSpecial Link:=False, DataType:=3, _
    Placement:=bMark.Start, DisplayAsIcon:=False
    For i = 1 To 10
        oWord.Selection.TypeParagraph
    Next

    Exit Sub
Err_Handler:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume Next
End Sub

Sub DataPaste()
    Dim t As Word.Range
    Data2Word
    oWordDoc.Bookmarks.Add Name:="DB"
    Set t = oWordDoc.Bookmarks("DB").Range
    t.Paste
    With t
        .Tables(1).Columns.SetWidth (rng.Width / rng.Columns.Count), wdAdjustSameWidth
    End With
    Set bMark = Nothing
End Sub
Sub Data2Word()
    Dim i%, crow%
              
    Sheets("Temp").UsedRange.ClearContents
    For i = 2 To LastRow(ThisWorkbook.Name, "Sheet1")
        If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
            crow = LastRow(ThisWorkbook.Name, "Temp") + 1
            Sheets("Temp").Range("a" & crow & ":r" & crow).Value = _
            Sheets("Sheet1").Range("a" & i & ":r" & i).Value
        End If
    Next
    Set rng = Sheets("Temp").UsedRange
    rng.HorizontalAlignment = xlCenter  'center align the data
    rng.Copy                            'copy the range
        
End Sub

 

[sharky12345]

I get an error message with that;

Sub test()
    PasteIntoWordDocument 1
    PasteIntoWordDocument 2
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts4.docx", FileFormat:= _
        wdFormatDocumentDefault, LockComments:=False, _
        AddToRecentFiles:=True, EmbedTrueTypeFonts:=False
    Set oWordDoc = Nothing
    Set oWord = Nothing
End Sub

'wdFormatDocumentDefault' is highlighted and the message says variable not defined.

Have I missed something obvious?

 

[Worf]

'wdFormatDocumentDefault' is highlighted and the message says variable not defined.

Hi

1. At the VB window, go to Tools/References and make sure the following is checked:
- Microsoft Office Object Library
- Microsoft Word Object Library

2. If you are not using Excel 07, change it to wdFormatDocument. If this still doesn't work, search the Word help for the WdSaveFormat enumeration and choose a constant there, according to its description.

 

[sharky12345]

It's progress!

But I'm getting a compile error saying 'sub or function not defined' and 'LastRow' highted from below;

Sub Data2Word()
    Dim i%, crow%
 
    Sheets("Temp").UsedRange.ClearContents
    For i = 2 To [B][COLOR=red]LastRow[/COLOR][/B](ThisWorkbook.Name, "Database")
        If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
            crow = LastRow(ThisWorkbook.Name, "Temp") + 1
            Sheets("Temp").Range("a" & crow & ":r" & crow).Value = _
            Sheets("Sheet1").Range("a" & i & ":r" & i).Value
        End If
    Next
    Set rng = Sheets("Temp").UsedRange
    rng.HorizontalAlignment = xlCenter  'center align the data
    rng.Copy                            'copy the range
 
End Sub

 

[Worf]

Very easy to fix...

The LastRow function is at the code window on post#2. Copy and paste in your current module.

 

[sharky12345]

Worf,

I've tried the code and it does start to paste the Charts into word but then just hangs. Is there anything obvious that I've missed?

Just for your info - I only want it to grab non empty cells from A3:R3000 inclusive.

Option Explicit
Dim rng As Range, oWordDoc As Object, oWord As Object, bMark
Sub test()
    PasteIntoWordDocument 1
    PasteIntoWordDocument 2
    DataPaste
    oWord.ChangeFileOpenDirectory ThisWorkbook.Path & "\"
    oWordDoc.SaveAs Filename:="Charts4.docx", FileFormat:= _
        wdFormatDocument, LockComments:=False, _
        AddToRecentFiles:=True, EmbedTrueTypeFonts:=False
    Set oWordDoc = Nothing
    Set oWord = Nothing
End Sub
Sub PasteIntoWordDocument(snumber%)
    Const wdPasteMetafilePicture = 3
    Dim sFile$, sBMname$, i%
 
    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
    '------------------------------------------
    Sheets("Stats").ChartObjects(snumber).Copy
    '------------------------------------------
    Set oWordDoc = oWord.Documents.Open(sFile)
    oWord.Visible = True
    '------------------------------------------
    sBMname = "BM" & snumber
    '------------------------------------------
    oWordDoc.Activate
    oWord.Selection.EndKey unit:=wdStory
    While oWordDoc.Bookmarks.Count > 0
        oWordDoc.Bookmarks(oWordDoc.Bookmarks.Count).Delete
    Wend
    oWordDoc.Bookmarks.Add Name:=sBMname
    Set bMark = oWord.ActiveDocument.Bookmarks(sBMname)
    bMark.Select
    '------------------------------------------
    oWord.Selection.PasteSpecial Link:=False, DataType:=3, _
    Placement:=bMark.Start, DisplayAsIcon:=False
    For i = 1 To 10
        oWord.Selection.TypeParagraph
    Next
    Exit Sub
Err_Handler:
    MsgBox Err.Description, vbCritical, Err.Number
    Resume Next
End Sub
Sub DataPaste()
    Dim t As Word.Range
    Data2Word
    oWordDoc.Bookmarks.Add Name:="DB"
    Set t = oWordDoc.Bookmarks("DB").Range
    t.Paste
    With t
        .Tables(1).Columns.SetWidth (rng.Width / rng.Columns.Count), wdAdjustSameWidth
    End With
    Set bMark = Nothing
End Sub
Sub Data2Word()
    Dim i%, crow%
 
    Sheets("Temp").UsedRange.ClearContents
    For i = 2 To LastRow(ThisWorkbook.Name, "Database")
        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                            'copy the range
 
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:=[A2], SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious).Row
End Function

 

[Worf]

I've tried the code and it does start to paste the Charts into word but then just hangs. Is there anything obvious that I've missed?
Just for your info - I only want it to grab non empty cells from A3:R3000 inclusive.

Do you know how to use the VBA Debugger?
Case Yes
Use it to discover what portion of the code is hanging and tell me.
Case No
Say so and we'll find another way to debug it.

Concerning your range, I suggest we test it with only a few lines first, afterwards let's deal with the real one. Easy to modify.
I'm using LastRow because my test sheet has only 10 lines.