VBA-Copy data from Excel to Word

[george hart]

The code below was working fine in that it activated my word doc "HSS Fleet Report 0500" - just suddenly stopped working, no error msg though.

It also should copy data from my excel file and paste into the "HSS Fleet Report 0500" word doc but doesn't.

Any ideas would be most appreciated as I'm loosing the will...

Dim WordApp As Object
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "HSS Fleet Report 0500"
WDoc = ThisWorkbook.Path & "\" & myDoc & ".doc"
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then
' no current word application
Set WordApp = CreateObject("Word.application")
Set wrdDoc = WordApp.Documents.Open(WDoc)
WordApp.Visible = True
Else
' word app running
For Each tmpDoc In WordApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = WordApp.Documents.Open(WDoc)

'Excel copy etc
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

WordApp.Activate

ActiveWorkbook:
Selection.PasteSpecial Link:=False, DataType:=20, Placement:=wdInLine, _
DisplayAsIcon:=False
End If
End If
End Sub

HELP please...

 

[Kenneth Hobson]

Comment out the On Error Resume Next and then run it to see where it fails. You will need to comment out the other lines too. Or, just use Debug by pressing F8 in the code.

 

[george hart]

Thanks, tried that but still nothing. no error or anything??

 

[Kenneth Hobson]

There are some things that your macro should consider. For one, check that the file exists. After this line:

WDoc = ThisWorkbook.Path & "\" & myDoc & ".doc"

Add:

MsgBox Dir(WDoc = ThisWorkbook.Path & "\" & myDoc & ".doc")

If nothing is shown, then the file does not exist.

 

[george hart]

All sorted now.

As I know the word doc will be open I just used this: The only problem I now have is that it doesn't copy the data over from the excel file.?? Any ideas.

Dim WordApp As Object
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String
myDoc = "HSS Fleet Report 0500"
WDoc = ThisWorkbook.Path & "\" & myDoc & ".doc"
'On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
WordApp.Activate
'Excel copy etc
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy


'WordApp.Activate

ActiveWorkbook:
Selection.PasteSpecial Link:=False, DataType:=20, Placement:=wdInLine, _
DisplayAsIcon:=False

 

[Kenneth Hobson]

Both Excel and MSWord have a Selection object. So, prefix Selection with Excel like Excel.Selection to be literal and for sure do it for your WordApp object when using Selection. WordApp.Selection

Since you may be using a late binding method with CreateObject or GetObject, constants in the MSWord application like wdInLine will not work. I normally get the constant values from MSWord's VBE since I record a macro there anyway to start that sort of project. To find the value in Excel, I would recommend doing an early binding to MSWord and type in VBE's Immediate Window:

MsgBox wdInLine

What I like to do with constants like that is to define them in the code. That way, they still make sense when using late binding methods.

Here is an example showing the Selection object in MSWord. The constants used, works because I had set the Microsoft Word 14.0 Object Library in VBE's Tools > References. There is nothing wrong with using both late and early binding methods. You get the best of both worlds.

Option Explicit
'http://www.vbaexpress.com/forum/showthread.php?t=33463
Sub ExportCellsToWordBookMarks()
    Dim wdApp As Word.Application
    Dim myDoc As Word.Document
    Dim mywdRange As Word.Range
    Dim bm As Word.Bookmark, bmName As String, s As String
    Dim r As Excel.Range
    Dim doc As String
    
    doc = "x:\msword\ExportCellsToWordBookMarks.docx"
    If Dir(doc) = "" Then
      MsgBox "Error, file does not exist." & vbLf & doc, vbCritical, "File is Missing"
      Exit Sub
    End If
     
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo errorHandler
     
      Set myDoc = wdApp.Documents.Add(Template:=doc)
      wdApp.Visible = True
       
    For Each bm In myDoc.Bookmarks
      bmName = bm.Name
      If Left(bmName, 5) = "excel" Then
        Set r = Excel.Range(Right(bmName, Len(bmName) - 5))
        If r.Value = "" Then
          bm.Select
          wdApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
          s = wdApp.Selection.Text
          While Left(s, 1) = " "
            wdApp.Selection.TypeBackspace
            'wdApp.Selection.Delete Unit:=wdCharacter, Count:=1
            'wdApp.Selection.Select
            wdApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
            s = wdApp.Selection.Text
          Wend
          wdApp.Selection.MoveRight
          bm.Delete
          Else
            bm.Range.Text = r.Value
        End If
      End If
    Next bm
    
    Set wdApp = Nothing
    Set myDoc = Nothing
    Set mywdRange = Nothing
    Exit Sub

 

[george hart]

Got it. This works a treat. Just found it o the web!!!!


Dim WordApp As Object
Dim wrdDoc As Object
Dim tmpDoc As Object
Dim WDoc As String
Dim myDoc As String

myDoc = "HSS Fleet Report 0500"
WDoc = ThisWorkbook.Path & "\" & myDoc & ".doc"

Set WordApp = GetObject(, "Word.Application")
'Excel copy etc
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
WordApp.Activate
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _
Placement:=wdInLine, DisplayAsIcon:=False