Copy all of word doc to excel sheet

[W1ordvba]

Hi,

I am trying to automate Copying all of a word doc to an excel sheet.
Also, how do you check if word doc is open already and close it.
I know you;d probably use a for ..next loop.


Sub copy_word_2_xl()

Dim WordApp As Object

'Open Word
Set WordApp = CreateObject("Word.application")
WordApp.Visible = True


WordApp.Documents.Open Filename:="S:\Word\LECTURE.doc", ReadOnly:=False
'Refer to the WordApp objct to write to word from excel
activedocument.COPY
Workbooks("Course").Activate
Sheets("Remedy_copyhere").[a1].Select
ActiveSheet.Paste


'Close Word
'WordApp.Quit
'Set WordApp = Nothing




End Sub

 

[SkipVought]

hi,

Sub copy_word_2_xl()

    Dim WordApp As Object, rng As Object
     
     'Open Word
    Set WordApp = CreateObject("Word.application")
    WordApp.Visible = True
    
 
    With WordApp.Documents.Open(Filename:="C:\Documents and Settings\ii36250\My Documents\LateToRQ_Documentation.docx", ReadOnly:=False)
         'Refer to the WordApp objct to write to word from excel
         Set rng = WordApp.Selection.Range
         rng.wholestory
         rng.Copy
         ThisWorkbook.Sheets(1).[a1].Select
         ActiveSheet.Paste
         
        'Close Word
        .Close
        'WordApp.Quit
        WordApp.Quit
        'Set WordApp = Nothing
        Set workapp = Nothing
        Set rng = Nothing
    End With


End Sub

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[W1ordvba]

Thx again, Skip.

 

[macropod]

hi Skip,

Ugly code! Try:

Sub ImportDoc()
Dim WordApp As Object
'Start Word
Set WordApp = CreateObject("Word.application")
With WordApp
  ' Open the document
  .Documents.Open Filename:="C:\Documents and Settings\ii36250\My Documents\LateToRQ_Documentation.docx", ReadOnly:=False
  ' Copy the content
  .ActiveDocument.Range.Copy
  ' Close the document without saving
  .ActiveDocument.Close SaveChanges:=False
  ' Close Word
  .Quit
End With
Set WordApp = Nothing
With ThisWorkbook.Sheets(1)
  .Paste Destination:=.Range("A1")
End With
End Sub

Cheers
Paul Edstein
[MS MVP - Word]