Copying everything from Word and pasting in specific cell.

[noveske]

Trying to copy text only. Testing with just basic line of text.

When running I get run-time error '1004':
PasteSpecial method of Range class failed.

Could it be that it's a merged cell? Tried to unmerge, then remerge. But it stops with the same error.

I've been using notepad, but would like to use Word for spell check.
Doing it this way since I have the sheet formatted to print to a form and line up with the boxes.

Sub CopyOver ()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim ExcelApp As Object
    Dim ExcelSheet As Object
    Dim FilePath As String
    Dim sheetProtection As String
    
    FilePath = ThisWorkbook.Path & "\101.docx"
    
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(FilePath)
    
    WordDoc.Content.Copy

    WordDoc.Close
    WordApp.Quit
    
    Set ExcelApp = GetObject(, "Excel.Application")
    Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets("Input")
    ExcelSheet.Activate
    
    ExcelSheet.Range("A23").PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False
    
End Sub

 

[DanteAmor]

FIRST: You must remove the merged cells.

It may be that at the time of pasting the memory is empty and that may be because you closed Word and that perhaps is clearing the memory.
Change the quit and close lines after the paste and try again:

Sub CopyOver()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim ExcelApp As Object
    Dim ExcelSheet As Object
    Dim FilePath As String
    Dim sheetProtection As String
    
    FilePath = ThisWorkbook.Path & "\103.docx"
    
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(FilePath)
    
    WordDoc.Content.Copy
    
    Set ExcelApp = GetObject(, "Excel.Application")
    Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets("Input")
    ExcelSheet.Activate
    
    ExcelSheet.Range("A23").PasteSpecial xlPasteValues
    
    WordDoc.Close
    WordApp.Quit
    
    Application.CutCopyMode = False
    
End Sub

 

[noveske]

FIRST: You must remove the merged cells.

It may be that at the time of pasting the memory is empty and that may be because you closed Word and that perhaps is clearing the memory.
Change the quit and close lines after the paste and try again:

Sub CopyOver()
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim ExcelApp As Object
    Dim ExcelSheet As Object
    Dim FilePath As String
    Dim sheetProtection As String
   
    FilePath = ThisWorkbook.Path & "\103.docx"
   
    Set WordApp = CreateObject("Word.Application")
    Set WordDoc = WordApp.Documents.Open(FilePath)
   
    WordDoc.Content.Copy
   
    Set ExcelApp = GetObject(, "Excel.Application")
    Set ExcelSheet = ExcelApp.ActiveWorkbook.Sheets("Input")
    ExcelSheet.Activate
   
    ExcelSheet.Range("A23").PasteSpecial xlPasteValues
   
    WordDoc.Close
    WordApp.Quit
   
    Application.CutCopyMode = False
   
End Sub

I tried this and it just gets stuck on the blue spinning circle. Waited a while to see if it would finish and it doesn't. Tried multiple times and have to close out with Task Manager.

After thinking, I wondered if I could use the old code that I was using with Notepad and I think I found a solution. Made some changes and it seems to be working.

Thanks @DanteAmor ! Your post got me to figuring this one out. Was able to do it while retaining the merged cell. Wish I could just copy all of your knowledge.

Sub CopyTextFile()

Dim oWordDoc As Object

    Dim oWordApp As Object: Set oWordApp = CreateObject("Word.Application")

    Set oWordDoc = oWordApp.Documents.Open(ThisWorkbook.Path & "\103.docx", ReadOnly:=True)

    Dim sText

    On Error GoTo ErrHandler:

    sText = oWordDoc.Content.Text

    
ErrHandler:
    If Err.Number = 62 Then
        ErrMsg = Error(Err.Number)
        Exit Sub
    End If
    
    oWordDoc.Close SaveChanges:=False
    
    ActiveSheet.Unprotect "pp"
    
    ThisWorkbook.Sheets(1).Range("A23").value = sText
    
    ActiveSheet.Protect "pp"
End Sub

 

[DanteAmor]

I tried this and it just gets stuck on the blue spinning circle.

That problem occurs because you cannot open the file, since it was not closed correctly.

To close you use the WordDoc.Close instruction but if it never reaches that instruction then the file remains open.



Use the following to close all the books that were left open and try again.

Sub closeall()
    Dim appWord As Object
    Dim wdDoc As Object
    Dim xd As Object
    Set appWord = GetObject(, "Word.Application")
    For Each xd In appWord.Documents
      xd.Close
    Next
    appWord.Quit
End Sub

 

[noveske]

That problem occurs because you cannot open the file, since it was not closed correctly.

To close you use the WordDoc.Close instruction but if it never reaches that instruction then the file remains open.



Use the following to close all the books that were left open and try again.

Sub closeall()
    Dim appWord As Object
    Dim wdDoc As Object
    Dim xd As Object
    Set appWord = GetObject(, "Word.Application")
    For Each xd In appWord.Documents
      xd.Close
    Next
    appWord.Quit
End Sub

So because it doesn't reach:

ExcelSheet.Range("A23").PasteSpecial xlPasteValues

it doesn't continue onto to close.

But even on close, shouldn't the data still be retained/saved in memory unless it was told to clear?

 

[DanteAmor]

But even on close, shouldn't the data still be retained/saved in memory unless it was told to clear?

I guess it's a problem in the versions, when you close the application it cleans the memory.

Something happens with your macro that is clearing the memory, that problem does not happen to me and your macro works fine.