Errore ora di esecuzione '1004': Incolla metodo del foglio di lavoro Classe Errore non valido

Copia incollare una row di text da parola ad eccellere utilizzando VBA.

Quando il codice raggiunge la linea sottostante, ottengo l'errore di seguito.

ActiveSheet.Paste 

Errore ora di esecuzione '1004': Incolla metodo del foglio di lavoro Classe Errore non valido

Ma se faccio clic sul button Debug e premete F8, incollerò i dati in excel senza alcun errore.

Questo errore si verifica each volta che il ciclo continua e premendo debug e F8 incollando i dati in modo piacevole.

Ho fatto diversi test e non sono riusciti a trovare la causa principale di questo problema.

Anche DoEvents utilizzato prima di incollare il codice dati, ma nulla ha funzionato.

Eventuali suggerimenti?

EDIT: –

Sto postando il codice poiché entrambi stanno dicendo lo stesso. Ecco il codice per la tua recensione.

 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 

Se vuoi sapere perché ho scelto la parola per il riassembly, per favore vai al link sottostante. http://www.excelforum.com/excel-programming-vba-macros/1128898-vba-characters-function-fails-when-the-cell-content-exceeds-261-characters.html

Utilizza anche il codice dal link sottostante per get il numero di sostituzioni conteggi.

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

Characters(start, length).Delete() metodo Characters(start, length).Delete() metodo sembra non funzionare con stringhe più lunghe in Excel 🙁 Quindi un metodo personalizzato Delete() potrebbe essere scritto che funziona con informazioni e testi di formatura disaccoppiati.Quindi il text della cella può essere modificato senza perdere le informazioni di formattazione.

Aggiungi nuova class denominata MyCharacter . Conterrà informazioni sul text e la formattazione di un carattere:

 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 

Aggiungere la nuova class successiva denominata MyCharcters e avvolgere il codice del nuovo metodo Delete . Con il metodo Filter viene creata una nuova collezione di MyCharacter . Questa raccolta contiene solo i caratteri che dovrebbero rimanere. Infine nel metodo Rewrite il text viene ri-scritto da questa raccolta di nuovo all'intervallo di destinazione insieme alla formattazione delle informazioni:

 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 

Come usarlo:

 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 

Prima:

Prima di eliminare

Dopo:

Dopo l'eliminazione

Per renderlo più stabile, dovresti:

  • Disabilita tutti gli events durante il funzionamento
  • Non call mai. Attiva o .Seleziona
  • Incollare direttamente nella cella mirata con WorkSheet.Paste
  • Annullare l'operazione di copia con Application.CutCopyMode = False
  • Riutilizzare lo stesso documento e non crearne uno per each iterazione
  • Fai come less operazioni in una iterazione
  • Utilizza l'associazione anticipata [New Word.Application] invece di legame tardivo [CreateObject ("Word.Application")]

Il tuo esempio ha rifatturato:

 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 

Come cambiarlo da: activesheet.paste a: activesheet.activate activecell.pastespecial xlpasteAll

Questo post sembra spiegare il problema e fornire due soluzioni:

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

Due articoli vengono scoperti in questo post:

  1. Provare a utilizzare Incolla speciale
  2. Specificare l'intervallo a cui si desidera incollare.

Un'altra soluzione sarebbe quella di estrarre le cellule come XML, sostituire il text con un'espressione regolare e quindi scrivere l'XML sul foglio. Mentre è molto più veloce di lavorare con Word, potrebbe richiedere alcune conoscenze con espressioni regolari se i formati dovrebbero essere gestiti. Inoltre funziona solo con Excel 2007 e superiore.

Ho assemblato un esempio che sostituisce tutte le occorrenze con lo stesso stile:

 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 arrays 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 

La risposta di DDuffy è utile.
Ho trovato che il codice può funzionare normalmente a PC lentamente CPU.
aggiungere il codice muto prima di incollare, il problema è eliminato:

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