运行时错误“1004”：工作表类的粘贴方法失败错误答案

【问题标题】：Run Time Error '1004': Paste Method Of worksheet Class Failed error运行时错误“1004”：工作表类的粘贴方法失败错误
【发布时间】：2016-06-16 16:04:05
【问题描述】：

使用 VBA 将 1 行文本从 word 复制粘贴到 excel。

当代码到达以下行时，我收到以下错误。

ActiveSheet.Paste

运行时错误“1004”：工作表类的粘贴方法失败错误

但是如果我点击调试按钮并按F8，那么它会将数据粘贴到excel中没有任何错误。

每次循环继续并按调试和 F8 很好地粘贴数据时都会发生此错误。

我进行了多次测试，但无法找到此问题的根本原因。

在粘贴数据代码之前也使用了 DoEvents，但没有任何效果。

有什么建议吗？

编辑：-

我发布代码是因为你们俩都说同样的话。这是供您查看的代码。

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

如果您想知道我为什么选择替换词，请通过以下链接。 http://www.excelforum.com/excel-programming-vba-macros/1128898-vba-characters-function-fails-when-the-cell-content-exceeds-261-characters.html

还使用以下链接中的代码来获取替换次数。

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

【问题讨论】：

你能再展示一些你的代码吗...？
感谢您的回复，但代码与此错误完全无关。我的问题是为什么当我按调试并按 F8 时它会起作用，为什么它不自己粘贴数据。
the code is not at all related to this error 运行时错误是您的代码有问题。除非我们能看到在该错误之前发生了什么，否则我们无能为力。
你错了，导致错误的不是ActiveSheet.Paste，而是之前的所有内容加上.Paste method。显示更多代码可以让我们提出更多问题并提供支持。我们不知道您复制的是哪一行文档，您是如何定义的等等，所以......？
我已经用您的评论代码更新了我的初始帖子。请建议我无法解决此问题。

标签： vba excel

【解决方案1】：

Characters(start, length).Delete() 方法似乎确实不适用于 Excel 中的较长字符串 :(。因此可以编写一个自定义的 Delete() 方法，该方法将适用于解耦的格式信息和文本。因此可以修改单元格的文本而无需丢失格式化信息。HTH。

添加名为MyCharacter 的新类。它将包含有关文本和一个字符的格式：

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

添加下一个名为MyCharcters 的新类并包装新类的代码 Delete 方法。使用Filter 方法会创建一个新的MyCharacter 集合。此集合仅包含应保留的字符。最后在方法Rewrite 中，该集合中的文本连同格式信息一起被重写回目标范围：

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

使用方法：

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

之前：

之后：

【讨论】：

感谢您努力解决我的问题。您能否告诉我这行代码中的 300 和 27 指的是什么？ " myChars.Delete target, 300, 27" 如果我没记错的话就是文本的开头和长度。但是，当使用 characters() 函数确定文本超过 261 个字符时，它会失败。如果我遗漏了什么，请纠正我。
请查看编辑后的答案，代码中有一个错误，其中确定了结束位置。是的300 是start 和27 是length。不，使用Range 的Characters 属性确定Text 即使跨越261 个字符也有效。但是，不能使用 261 个字符的是 Delete 方法。（用 Excel 2007 测试）
感谢您的持续努力。但是您仍然缺少我的实际要求。如果您在 excelforum.com 链接上看到我的实际问题，我在其中清楚地解释了 characters() 函数用于确定搜索文本位置并执行替换任务的实际需要。这就是为什么我选择使用没有所有这些限制和问题的 Microsoft Word 方法。唯一的问题是，在将数据从 word 粘贴到 excel 时，会发生运行时错误。我想摆脱这个运行时错误问题。希望您了解情况。
我明白了，这是我的误解 :)。我将详细说明确定搜索文本的位置并执行替换任务。
不知道问题出在哪里。尝试使用 Paste 而不明确选择目标范围。这可以在指定Destination 参数时实现。所以将这两行r.Select 和ActiveSheet.Paste 替换为一行r.Parent.Paste Destination:=r。请参阅Worksheet.Paste 方法的文档。

【解决方案2】：

为了让它更稳定，你应该：

在操作时禁用所有事件
永远不要调用 .Activate 或 .Select
使用 WorkSheet.Paste 直接粘贴到目标单元格中
使用 Application.CutCopyMode = False 取消复制操作
重复使用同一个文档，而不是为每次迭代创建一个文档
在迭代中尽可能少地执行操作
使用早期绑定 [New Word.Application] 而不是后期绑定 [CreateObject("Word.Application")]

您的示例已重构：

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

【讨论】：

【解决方案3】：

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

【讨论】：

【解决方案4】：

这篇文章似乎解释了这个问题并提供了两种解决方案：

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

这篇文章中提到了两个项目：

尝试使用选择性粘贴
指定要粘贴到的范围。

【讨论】：

【解决方案5】：

另一种解决方案是将目标单元格提取为 XML，用正则表达式替换文本，然后将 XML 写回工作表。虽然它比使用 Word 快得多，但如果要处理格式，它可能需要一些正则表达式知识。此外，它仅适用于 Excel 2007 及更高版本。

我已经组装了一个用相同样式替换所有出现的示例：

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

【讨论】：

【解决方案6】：

DDuffy 的回答很有用。
我发现代码可以在慢速cpu PC上正常运行。
粘贴前添加如下代码，问题解决：

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

【讨论】：