Solved: Pasting from Word into Excel

[mdmackillop]

I've to copy all the Word documents in a folder (they consist only of tables) and paste each into a new worksheet. I'm missing something on the Paste code as I'm getting Error 438, Object does not support this Property or Method. I can manually paste from that point on the code, so the rest is OK


Option Explicit
Sub Imports()
Dim WD As Object
Dim Doc As Object
Dim RDSPath As String
Dim WB As Workbook
Dim aRange
Dim RDSFile As String

Set WB = ActiveWorkbook
Set WD = CreateObject("Word.Application")
WD.Visible = False
RDSPath = "C:\AAA\"
RDSFile = Dir(RDSPath & "*.doc")
Do
Set Doc = WD.Documents.Open(RDSPath & RDSFile)
Set aRange = Doc.Range
aRange.Copy
WB.Sheets.Add Sheets(1)
'***********************************
WB.Sheets(1).Range("A1").Paste
Set WD = Nothing
Loop
WD.Quit
End Sub

[Norie]

Perhaps you should add the sheet before the copy?

PS Am I missing something? You seem to have no conditions for your loop.

[Dave]

You also seem to be setting the WD object to nothing and then trying to use it to quit the application. This won't work. HTH. Dave

[Charlize]

Sub Imports()
Dim WD As Object
Dim Doc As Object
Dim arange
Dim WB As Workbook
Dim RDSFiles
Dim i As Long
'added this line
Dim copytosheet As Worksheet
Set WB = ActiveWorkbook
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set RDSFiles = Application.FileSearch
With RDSFiles
.LookIn = "C:\Data\"
.FileType = msoFileTypeWordDocuments
.Execute
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Set Doc = WD.Documents.Open(.FoundFiles(i))
Set arange = Doc.Range
arange.Copy
'changed this line
Set copytosheet = WB.Sheets.Add
'***********************************
'changed it to this
copytosheet.Paste
'WB.Sheets(1).Range("A1").Paste
Doc.Close
'Set WD = Nothing
Next i
End If
End With
WD.Quit
End Sub

[mdmackillop]

Thanks Charlize. That solved the problem.
Thanks to others. I fixed to loop etc. once my code got that far!


Sub Imports()
Dim WD As Object
Dim Doc As Object
Dim RDSPath As String
Dim WB As Workbook
Dim aRange
Dim RDSFile As String
Dim Rw As Long
Dim CopyToSheet As Worksheet
Dim c As Range
Application.EnableEvents = False

Set WB = ActiveWorkbook
Set WD = CreateObject("Word.Application")
WD.Visible = False
RDSPath = "C:\Data\"
RDSFile = Dir(RDSPath & "*.doc")
Do Until RDSFile = ""
Set Doc = WD.Documents.Open(RDSPath & RDSFile)
Set aRange = Doc.Range
aRange.Copy
Set CopyToSheet = WB.Sheets.Add(After:=Sheets(Sheets.Count))
CopyToSheet.Paste
With CopyToSheet
.Range("A1").Select
Set c = .Columns(2).Find("Schedule of Components by Room")
If Not c Is Nothing Then Rows(1 & ":" & c.Row - 1).Delete
End With
Doc.Close False
RDSFile = Dir
Loop
WD.Quit
Set WD = Nothing
Application.EnableEvents = True

End Sub