Question

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

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

ActiveSheet.Paste

运行时错误＆＃39; 1004＆＃39 ;:粘贴方法工作表类失败错误

但是如果我单击“调试”按钮并按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

Answer 1

Characters(start, length).Delete()方法似乎无法在Excel中使用更长的字符串:(。因此可以编写自定义Delete()方法，该方法将与解耦的格式化信息和文本一起使用。因此，单元格的文本可以修改而不会丢失格式化信息.HPH。

添加名为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

在：

后：

Answer 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

Answer 3

如何更改它：activesheet.paste 至： activesheet.activate activecell.pastespecial xlpasteAll

Answer 4

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

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

这篇文章中有两个项目出现：

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

Answer 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

Answer 6

DDuffy的回答非常有用我发现代码可以在缓慢的cpu PC上正常运行在粘贴之前添加波纹管代码，问题解决了：

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

运行时错误＆＃39; 1004＆＃39 ;:粘贴方法工作表类失败错误

6 个答案: