运行时错误“1004”：粘贴工作表类错误的方法
使用VBA复制粘贴1行文本到excel。
当代码到达下面的线我得到下面的错误。
ActiveSheet.Paste 运行时错误“1004”：粘贴工作表类错误的方法
但是， 如果我点击debuggingbutton，然后按F8然后它粘贴在Excel中的数据没有任何错误。
每次循环进行时都会出现此错误，并按下debugging和F8粘贴数据。
我做了几个testing，无法find这个问题的根本原因。
在粘贴数据代码之前还使用了DoEvents ，但没有任何工作。
有什么build议么？
编辑：-
我发布的代码，因为你们都说同样的。 这是你的评论的代码。
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
如果你想知道为什么我select了replace的话，请通过下面的链接。 http://www.excelforum.com/excel-programming-vba-macros/1128898-vba-characters-function-fails-when-the-cell-content-exceeds-261-characters.html
还使用下面的链接代码来获取replace次数。
http://word.mvps.org/faqs/macrosvba/GetNoOfReplacements.htm
Characters(start, length).Delete()方法真的似乎不适用于更长的string在Excel :(所以一个自定义的Delete()方法可以被写入，这将与解耦合的信息和文本工作。可以修改而不会丢失格式化信息。
添加名为
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方法创build一个新的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
之前：
后：
为了使它更稳定，你应该：
- 操作时禁用所有事件
- 切勿调用。激活或。select
- 使用WorkSheet.Paste直接粘贴到目标单元格中
- 取消Application.CutCopyMode = False的复制操作
- 重复使用相同的文档，而不是为每个迭代创build一个
- 在迭代中尽可能减less操作
- 使用早期绑定[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
如何将它从： activesheet.paste更改为： activesheet.activate activecell.pastespecial xlpasteAll
这篇文章似乎解释了这个问题并提供了两个解决scheme：
在这篇文章中有两个项目被点亮了：
- 尝试使用select性粘贴
- 指定您想要粘贴的范围。
另一个解决scheme是将目标单元格提取为XML，用正则expression式replace文本，然后将XML写回到表单中。 虽然它比使用Word要快得多，但如果要处理格式，则可能需要使用正则expression式的一些知识。 此外，它只适用于Excel 2007和卓越。
我已经组装了一个用相同样式replace所有事件的例子：
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
DDuffy的答案是有用的。
我发现代码可以在cpu PC上慢慢运行。
在粘贴之前添加下面的代码，问题是解决的：
Application.Wait (Now + TimeValue("0:00:1"))'wait 1s or more ActiveSheet.Paste