运行时错误'1004':工作表类的粘贴方法失败错误 [英] Run Time Error '1004': Paste Method Of worksheet Class Failed error

问题描述

使用VBA将1行文本从单词粘贴到excel.

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

运行时错误'1004':工作表的粘贴方法类失败错误

但是如果我单击调试"按钮并按F8键，则它将数据粘贴到excel中而没有任何错误.

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

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.

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

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

有什么建议吗?

-

我正在发布代码，因为你们两个都说的相同.这是供您审核的代码.

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

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

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

推荐答案

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

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.

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

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

添加下一个名为MyCharcters的新类，并包装新的代码 Delete方法.使用Filter方法，将创建MyCharacter的新集合.该集合仅包含应保留的字符.最后，在方法Rewrite中，将文本从此集合重新写入目标范围以及格式设置信息:

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

之前:

之后:

这篇关于运行时错误'1004':工作表类的粘贴方法失败错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！