運行時錯誤'1004'：粘貼方法工作表類失敗錯誤

Question

使用VBA將1行文本從word復制粘貼到excel。

當代碼到達下面的行時，我得到以下錯誤。

ActiveSheet.Paste

運行時錯誤'1004'：粘貼方法工作表類失敗錯誤

但是， 如果我單擊“調試”按鈕並按F8，那么它將在Excel中粘貼數據而不會出現任何錯誤。

每次循環繼續並按下調試和F8很好地粘貼數據時會發生此錯誤。

我做了幾次測試，無法找到此問題的根本原因。

在粘貼數據代碼之前也使用了DoEvent但沒有任何效果。

有什么建議？

編輯：-

我發布代碼，因為你們兩個都在說同樣的話。 這是您的評論代碼。

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

這篇文章中有兩個項目出現：

1. 嘗試使用選擇性粘貼
2. 指定要粘貼到的范圍。

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