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

Answer 1

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:

Answer 2

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

Answer 3

如何将其从： activesheet.paste更改为： activesheet.activate activecell.pastespecial xlpasteAll

Answer 4

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:

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

Answer 5

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

Answer 6

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