Run Time Error '1004': Paste Method Of worksheet Class Failed error

Question

Copy pasting 1 line of text from word to excel using VBA.

When the code reaches the below line I am getting the below error.

ActiveSheet.Paste

Run Time Error '1004': Paste Method Of worksheet Class Failed error

But if I click Debug button and press F8 then it's pasting the data in excel without any error.

This error occurs each time the loop goes on and pressing debug and F8 pasting the data nicely.

I did several testing and unable to find the root cause of this issue.

Also used DoEvents before pasting the data code but nothing worked.

Any suggestions?

EDIT:-

I am posting the code since both of you are saying the same. Here is the code for your review.

Sub FindAndReplace()
    Dim vFR As Variant, r As Range, i As Long, rSource As Range
    Dim sCurrRep() As String, sGlobalRep As Variant, y As Long, x As Long

    Dim NumCharsBefore As Long, NumCharsAfter As Long
    Dim StrFind As String, StrReplace As String, CountNoOfReplaces As Variant

    '------------------------------------------------
    Dim oWord As Object
    Const wdReplaceAll = 2

    Set oWord = CreateObject("Word.Application")
    '------------------------------------------------

    Application.ScreenUpdating = False

    vFR = ThisWorkbook.Sheets("Sheet1").Range("A1").CurrentRegion.Value

    On Error Resume Next
        Set rSource = Cells.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0

    If Not rSource Is Nothing Then
        For Each r In rSource.Cells
            For i = 2 To UBound(vFR)
                If Trim(vFR(i, 1)) <> "" Then
                    With oWord
                        .Documents.Add
                            DoEvents
                            r.Copy
                            .ActiveDocument.Content.Paste

                            NumCharsBefore = .ActiveDocument.Characters.Count

                            With .ActiveDocument.Content.Find
                                .ClearFormatting
                                .Font.Bold = False
                                .Replacement.ClearFormatting
                                .Execute FindText:=vFR(i, 1), ReplaceWith:=vFR(i, 2), Format:=True, Replace:=wdReplaceAll
                            End With

                            .Selection.Paragraphs(1).Range.Select
                            .Selection.Copy
                            r.Select
                            ActiveSheet.Paste'Error occurs in this line pressing debug and F8 is pasting the data

                            StrFind = vFR(i, 1): StrReplace = vFR(i, 2)
                            NumCharsAfter = .ActiveDocument.Characters.Count
                            CountNoOfReplaces = (NumCharsBefore - NumCharsAfter) / (Len(StrFind) - Len(StrReplace))
                            .ActiveDocument.UndoClear
                        .ActiveDocument.Close SaveChanges:=False

                        If CountNoOfReplaces Then
                            x = x + 1
                            ReDim Preserve sCurrRep(1 To 3, 1 To x)
                            sCurrRep(1, x) = vFR(i, 1)
                            sCurrRep(2, x) = vFR(i, 2)
                            sCurrRep(3, x) = CountNoOfReplaces
                        End If
                        CountNoOfReplaces = 0
                    End With
                End If
            Next i
        Next r
    End If
   oWord.Quit
'Some more gode goes here... which is not needed since error occurs in the above loop
End Sub

If you want to know why I have chosen word for replacement then please go through the below link. http://www.excelforum.com/excel-programming-vba-macros/1128898-vba-characters-function-fails-when-the-cell-content-exceeds-261-characters.html

Also used the code from the below link to get the number of replacements count.

http://word.mvps.org/faqs/macrosvba/GetNoOfReplacements.htm

Thanks for the reply but the code is not at all related to this error. My question is why it is working when I press debug and press F8 why not it's pasting the data on it's own. — Sixthsense, Mar 03 '16 at 11:10
`the code is not at all related to this error` a run time error ***is*** a problem with your code. Unless we can see what's happening before that error there's not a lot we can do. — SierraOscar, Mar 03 '16 at 11:15
your are wrong, it is not `ActiveSheet.Paste` which results with error but everything what is before plus `.Paste method`. showing more code allows us to ask more questions and provide support. We don't know which line of document you copy, how do you define it, etc. so...? — Kazimierz Jawor, Mar 03 '16 at 11:16
I have updated my initial post with the code for your reviews. Please suggest I am unable to fix the issue. — Sixthsense, Mar 03 '16 at 11:35
what if instead of `r.select and activesheet.paste` you use `r.pastespecial`? — Kazimierz Jawor, Mar 03 '16 at 11:53
Does activesheet refer to the word document or the spreadsheet? It seems awfully ambiguous which is probably what the issue is? — Doug Coats, Mar 03 '16 at 12:19
The `Active` objects can get thrown off if you are jumping around and switching focus (especially between other programs). First test: create a new variable `Dim wksht as Worksheet` and `Set wksht = ActiveSheet` before you open the Word document. This will give a reference that exists even if `ActiveSheet` gets changed later. — Byron Wall, Mar 03 '16 at 15:49
Quote: "what if instead of r.select and activesheet.paste you use r.pastespecial?" Tried it but its pasting it as Picture instead of Text. — Sixthsense, Mar 04 '16 at 06:46
Quote:"Does activesheet refer to the word document or the spreadsheet?" Refers to xl spreadsheet. For word it is activeDocument. — Sixthsense, Mar 04 '16 at 06:47
Quote: "Dim wksht as Worksheet and Set wksht = ActiveSheet before you open the Word document" Tried in that way also and the same error occurs on the wksht.Paste code — Sixthsense, Mar 04 '16 at 06:49
not a vba guru, but it sounds like its tripping over itself. what i mean by that is, when the code is running free, its moving too quickly (trying to paste before its finished copying), when youre stepping through, it has more time to copy the data. have you tried adding a 1 second wait in there? — DDuffy, Mar 08 '16 at 16:00

Daniel Dušek · Answer 1 · 2016-03-08T10:59:37.990

Characters(start, length).Delete() method really seems not to work with longer strings in Excel :(. So a custom Delete() method could be written which will work with decoupled formating informations and texts. So the text of the cell can be modified without loosing the formating information. HTH.

Add new class named MyCharacter. It will contain information about text and formating of one character:

Public Text As String
Public Index As Integer
Public Name As Variant
Public FontStyle As Variant
Public Size As Variant
Public Strikethrough As Variant
Public Superscript As Variant
Public Subscript As Variant
Public OutlineFont As Variant
Public Shadow As Variant
Public Underline As Variant
Public Color As Variant
Public TintAndShade As Variant
Public ThemeFont As Variant

Add next new class named MyCharcters and wrap the code of the new Delete method in it. With Filter method a new collection of MyCharacter is created. This collection contains only the characters which should remain. Finally in method Rewrite the text is re-written from this collection back to target range along with formating info:

Private m_targetRange As Range
Private m_start As Integer
Private m_length As Integer
Private m_endPosition As Integer

Public Sub Delete(targetRange As Range, start As Integer, length As Integer)
    Set m_targetRange = targetRange
    m_start = start
    m_length = length
    m_endPosition = m_start + m_length - 1

    Dim filterdChars As Collection
    Set filterdChars = Filter
    Rewrite filterdChars
End Sub

Private Function Filter() As Collection
    Dim i As Integer
    Dim newIndex As Integer
    Dim newChar As MyCharacter

    Set Filter = New Collection
    newIndex = 1

    For i = 1 To m_targetRange.Characters.Count
        If i < m_start Or i > m_endPosition Then
            Set newChar = New MyCharacter
            With newChar
                .Text = m_targetRange.Characters(i, 1).Text
                .Index = newIndex
                .Name = m_targetRange.Characters(i, 1).Font.Name
                .FontStyle = m_targetRange.Characters(i, 1).Font.FontStyle
                .Size = m_targetRange.Characters(i, 1).Font.Size
                .Strikethrough = m_targetRange.Characters(i, 1).Font.Strikethrough
                .Superscript = m_targetRange.Characters(i, 1).Font.Superscript
                .Subscript = m_targetRange.Characters(i, 1).Font.Subscript
                .OutlineFont = m_targetRange.Characters(i, 1).Font.OutlineFont
                .Shadow = m_targetRange.Characters(i, 1).Font.Shadow
                .Underline = m_targetRange.Characters(i, 1).Font.Underline
                .Color = m_targetRange.Characters(i, 1).Font.Color
                .TintAndShade = m_targetRange.Characters(i, 1).Font.TintAndShade
                .ThemeFont = m_targetRange.Characters(i, 1).Font.ThemeFont
            End With
            Filter.Add newChar, CStr(newIndex)
            newIndex = newIndex + 1
        End If
    Next i
End Function

Private Sub Rewrite(chars As Collection)
    m_targetRange.Value = ""

    Dim i As Integer
    For i = 1 To chars.Count
        If IsEmpty(m_targetRange.Value) Then
            m_targetRange.Value = chars(i).Text
        Else
            m_targetRange.Value = m_targetRange.Value & chars(i).Text
        End If
    Next i

    For i = 1 To chars.Count
        With m_targetRange.Characters(i, 1).Font
            .Name = chars(i).Name
            .FontStyle = chars(i).FontStyle
            .Size = chars(i).Size
            .Strikethrough = chars(i).Strikethrough
            .Superscript = chars(i).Superscript
            .Subscript = chars(i).Subscript
            .OutlineFont = chars(i).OutlineFont
            .Shadow = chars(i).Shadow
            .Underline = chars(i).Underline
            .Color = chars(i).Color
            .TintAndShade = chars(i).TintAndShade
            .ThemeFont = chars(i).ThemeFont
        End With
    Next i
End Sub

How to use it:

Sub test()
    Dim target As Range
    Dim myChars As MyCharacters

    Application.ScreenUpdating = False
    Set target = Worksheets("Demo").Range("A1")
    Set myChars = New MyCharacters
    myChars.Delete targetRange:=target, start:=300, length:=27
    Application.ScreenUpdating = True
End Sub

Before:

After:

Thanks for your effort in trying to fix my issue. Could you please let me know what is 300 & 27 refers in this line of code? " myChars.Delete target, 300, 27" If I am not wrong it is the start and length of the text. But determining the text using characters() function fails when it crosses over 261 characters. Please correct me if I am missing anything. — Sixthsense, Mar 08 '16 at 07:40
Please see edited answer, there was a bug in code where the end-position was determined. Yes ```300``` is ```start``` and ```27``` is ```length```. No, determining ```Text``` using ```Characters``` property of ```Range``` works even when it crosses over 261 characters. However what doesn't work with 261 characters is the ```Delete``` method. (Tested with Excel 2007) — Daniel Dušek, Mar 08 '16 at 11:05
Thanks for your continuous effort. But still you are missing my actual requirement. If you see my actual question on excelforum.com link in which I clearly explained the actual need of characters() function for determining the search text placement and do the replacement task. That's why I have gone for using Microsoft Word approach which works fine without all these restrictions and issues. The only thing is that while pasting the data from word to excel the run time error occurs. I would like to get rid of this run time error issue. Hope you understand the situation. — Sixthsense, Mar 08 '16 at 11:23
I see, an misunderstanding on my side :). I will elaborate on determining the search text placement and do the replacement task. — Daniel Dušek, Mar 08 '16 at 11:47
Well not sure where exactly the problem is. Try to use ```Paste``` without explicitly select the target range. This can be achieved when ```Destination``` parameter is specified. So replace those two lines ```r.Select``` and ```ActiveSheet.Paste``` with just one line ```r.Parent.Paste Destination:=r```. See documentation for [Worksheet.Paste](https://msdn.microsoft.com/library/office/ff821951.aspx) method. — Daniel Dušek, Mar 08 '16 at 13:42

score 2 · Answer 2 · answered Mar 11 '16 at 17:10

To make it more stable, you should:

Disable all events while operating
Never call .Activate or .Select
Paste directly in the targeted cell with WorkSheet.Paste
Cancel the Copy operation with Application.CutCopyMode = False
Reuse the same document and not create one for each iteration
Do as less operations as possible in an iteration
Use early binding [New Word.Application] instead of late binding [CreateObject("Word.Application")]

Your example refactored :

Sub FindAndReplace()
  Dim dictionary(), target As Range, ws As Worksheet, cell As Range, i As Long
  Dim strFind As String, strReplace As String, diffCount As Long, replaceCount As Long
  Dim appWord As Word.Application, content As Word.Range, find As Word.find

  dictionary = [Sheet1!A1].CurrentRegion.Value
  Set target = Cells.SpecialCells(xlCellTypeConstants)

  ' launch and setup word
  Set appWord = New Word.Application
  Set content = appWord.Documents.Add().content
  Set find = content.find
  find.ClearFormatting
  find.Font.Bold = False
  find.replacement.ClearFormatting

  ' disable events
  Application.Calculation = xlManual
  Application.ScreenUpdating = False
  Application.EnableEvents = False

  ' iterate each cell
  Set ws = target.Worksheet
  For Each cell In target.Cells

    ' copy the cell to Word and disable the cut
    cell.Copy
    content.Delete
    content.Paste
    Application.CutCopyMode = False

    ' iterate each text to replace
    For i = 2 To UBound(dictionary)
      If Trim(dictionary(i, 1)) <> Empty Then
        replaceCount = 0
        strFind = dictionary(i, 1)
        strReplace = dictionary(i, 2)

        ' replace in the document
        diffCount = content.Characters.count
        find.Execute FindText:=strFind, ReplaceWith:=strReplace, format:=True, Replace:=2

        ' count number of replacements
        diffCount = diffCount - content.Characters.count
        If diffCount Then
          replaceCount = diffCount \ (Len(strFind) - Len(strReplace))
        End If

        Debug.Print replaceCount
      End If
    Next

    ' copy the text back to Excel
    content.Copy
    ws.Paste cell
  Next

  ' terminate Word
  appWord.Quit False

  ' restore events
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

score 1 · Answer 3 · answered Mar 12 '16 at 02:48

1

How about change it from: activesheet.paste to: activesheet.activate activecell.pastespecial xlpasteAll

answered Mar 12 '16 at 02:48

Kenneth Chan

532
4
20

score 1 · Answer 4 · answered Mar 12 '16 at 03:16

This post seems to explain the problem and provide two solutions:

http://www.excelforum.com/excel-programming-vba-macros/376722-runtime-error-1004-paste-method-of-worksheet-class-failed.html

Two items come to light in this post:

Try using Paste Special
Specify the range you wish to paste to.

score 0 · Answer 5 · answered Mar 14 '16 at 01:41

Another solution would be to extract the targeted cells as XML, replace the text with a regular expression and then write the XML back to the sheet. While it's much faster than working with Word, it might require some knowledge with regular expressions if the formats were to be handled. Moreover it only works with Excel 2007 and superior.

I've assemble an example that replaces all the occurences with the same style:

Sub FindAndReplace()
  Dim area As Range, dictionary(), xml$, i&
  Dim matchCount&, replaceCount&, strFind$, strReplace$

  ' create the regex object
  Dim re As Object, match As Object
  Set re = CreateObject("VBScript.RegExp")
  re.Global = True
  re.MultiLine = True

  ' copy the dictionary to an array with column1=search and column2=replacement
  dictionary = [Sheet1!A1].CurrentRegion.Value

  'iterate each area
  For Each area In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)
    ' read the cells as XML
    xml = area.Value(xlRangeValueXMLSpreadsheet)

    ' iterate each text to replace
    For i = 2 To UBound(dictionary)
      If Trim(dictionary(i, 1)) <> Empty Then
        strFind = dictionary(i, 1)
        strReplace = dictionary(i, 2)

        ' set the pattern
        re.pattern = "(>[^<]*)" & strFind

        ' count the number of occurences
        matchCount = re.Execute(xml).count
        If matchCount Then
          ' replace each occurence
          xml = re.Replace(xml, "$1" & strReplace)
          replaceCount = replaceCount + matchCount
        End If
      End If
    Next

    ' write the XML back to the sheet
    area.Value(xlRangeValueXMLSpreadsheet) = xml
  Next

  ' print the number of replacement
  Debug.Print replaceCount

End Sub

Robin.Yu · Answer 6 · 2017-03-08T13:45:28.190

0

DDuffy's answer is useful.
I found the code can run normally at slowly cpu PC .
add the bellow code before paste, the problem is sloved：

Application.Wait (Now + TimeValue("0:00:1"))'wait 1s or more 
ActiveSheet.Paste

edited Mar 08 '17 at 13:45

answered Mar 08 '17 at 13:40

Robin.Yu

1
2

Run Time Error '1004': Paste Method Of worksheet Class Failed error

6 Answers6

Linked