Live-Forum - Die aktuellen Beiträge
Datum
Titel
23.04.2024 09:45:43
mehrere Bedingungen verknüpfen und mehr
23.04.2024 08:59:38
Bedingte Formatierung
23.04.2024 08:56:21
Mehrzeilige Zellen in einzelne Zeilen aufteilen & auswer
23.04.2024 08:26:15
Rückgabewert mehrere Suchkriterien Datumsbereich
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1748to1752
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1748to1752
1748to1752
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Mal gehts - mal wieder nicht

Mal gehts - mal wieder nicht
06.04.2020 17:46:42
Dennis
Hallo Zusammen,
ich hoffe ich kann mir euer Schwarmwissen mal Anzapfen.
Ich habe in einer Datei zwei Module, welche beide ziemlich oft laufen und genau das tun was sie sollen, und dann mal wieder nicht - dann springt der Debugger ein.
Modul 1 erstellt aus verschiedenen Diagrammen Kopien und setzt sie in ein neues Tabellenblatt als "Bild" ein.
Sub Makro1()
ClearClipboard = True
Sheets("D_01").Select
ActiveSheet.ChartObjects("Diagramm 1-1").Activate
Selection.Copy                        'copy charts
Sheets("Output").Select
Range("E10").Select                    'choose destination
ActiveSheet.Pictures.Paste.Select     'paste as pictures
Application.CutCopyMode = False
Sheets("D_01").Select
ActiveSheet.ChartObjects("Diagramm 1-2").Activate
Selection.Copy                        'copy charts
Sheets("Output").Select
Range("V10").Select                    'choose destination
ActiveSheet.Pictures.Paste.Select     'paste as pictures
Application.CutCopyMode = False
Sheets("PainPoint_tables").Select
Range("Tabelle10[#All]").Select
Selection.Copy
Sheets("Output").Select
Range("AM10").Select                    'choose destination
ActiveSheet.Pictures.Paste.Select     'paste as pictures
Application.CutCopyMode = False
Sheets("PainPoint_tables").Select
Range("Tabelle11[#All]").Select
Selection.Copy
Sheets("Output").Select
Range("BX10").Select                    'choose destination
ActiveSheet.Pictures.Paste.Select     'paste as pictures
Application.CutCopyMode = False
End Sub
Das Modul 2 löscht alle Bilder im Tabellenblatt: 
Sub DeleteAllPics()
Dim Pic As Object
Sheets("Output").Select
Range("C3").Select
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Range("C3").Select
Next Pic
End Sub

Als Fehler erscheint hin und wieder
Die Methode Copy für das Objekt ChartObjekt ist fehlgeschlagen.
Wenn ich einfach wieder auf weiter ausführen klicke gehts auch weiter.
Kann mir jemand weiterhelfen?
Vielen Dank im Voraus
Dennis.

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 18:07:06
Nepumuk
Hallo Dennis,
kopiere die Diagramme nach diesem Muster:
Do
    Call Worksheets("D_01").ChartObjects("Diagramm 1-1").CopyPicture(Appearance:=xlScreen, Format:=xlPicture) 'copy charts
    If Err.Number = 0 Then Exit Do
    Err.Clear
    DoEvents
Loop
On Error GoTo 0
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E10")) 'paste as pictures

Gruß
Nepumuk
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 18:13:50
Dennis
Userbild
Diese Fehlermeldung kommt grad oft...
AW: Mal gehts - mal wieder nicht
06.04.2020 18:17:04
Nepumuk
Hallo Dennis,
versuch es so:
Sub DeleteAllPics()
    
    Dim Pic As Shape
    
    For Each Pic In Worksheets("Output").Shapes
        If Pic.Type = msoPicture Then Call Pic.Delete
    Next Pic
    
End Sub

Gruß
Nepumuk
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 18:18:35
Dennis
Hallo Nepumuk,
also das geht auch - ich hab keine Ahnung was anders ist, aber das werd ich gerne so machen. Wie bekomm ich dann die andren Diagramm Kopiert? Einzelne Module anlegen?
Und was gerade ist, dass der Löschvorgang irgendwie hängt - also daran scheitert es auch... das verrückte ist halt nicht durchgängig, sonder nur hin und wieder.
Danke Dir / euch.
LG Dennis.
AW: Mal gehts - mal wieder nicht
06.04.2020 18:22:24
Nepumuk
Hallo Dennis,
du musst doch nur das vorhandene Makro nach dem Muster anpassen. Da kopierst du doch schon mehrere Diagramme.
Gruß
Nepumuk
AW: Mal gehts - mal wieder nicht
06.04.2020 18:26:17
Dennis
Suuuuuuper! Also so mach ich es!
Danke Nepumuk!
Sub Outputmodul()
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-1").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture) 'copy charts
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E10")) 'paste as  _
pictures
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-2").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture) 'copy charts
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("V10")) 'paste as  _
pictures
End Sub

Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 18:33:05
Dennis
Hallo Nepumuk,
eines noch: Bei den Diagrammen funktioniert es prima - danke sehr. Aber ich habe auch ein paar Tabellen zum Kopieren und als Bild einfügen. Da spinnt wieder der Debugger, klar, weil die Tabellen natürlich keine Diagramme sind:
Sheets("PainPoint_tables").Select
Range("Tabelle10[#All]").Select
Selection.Copy
Sheets("Output").Select
Range("AM10").Select 'choose destination
ActiveSheet.Pictures.Paste.Select 'paste as pictures
Application.CutCopyMode = False
Das ist mein aktueller Code dazu - soll ich den auch umstellen? Hast Du hierzu eine Idee?
Danke sehr. :-)
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 18:44:03
Nepumuk
Hallo Dennis,
ganz ähnlich:
On Error Resume Next
Do
    Call Worksheets("PainPoint_tables").Range("Tabelle10[#All]").CopyPicture
    If Err.Number = 0 Then Exit Do
    Call Err.Clear
    DoEvents
Loop
On Error GoTo 0
DoEvents
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM10"))
Application.CutCopyMode = False

Gruß
Nepumuk
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 19:08:52
Dennis
Hallo Nepumuk,
das funktioniert schon viel besser als meines! Danke sehr, da lern ich gerade echt viel.
Jedoch bleibt er bei den Tabellen mit immer unterschiedlichen Fehlern immer an folgendem Code hängen (auch hier, wenn ich auf weiter klicke gehts weiter)
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM10"))
Mal bleibt er an der ersten, mal an der Zweiten Tabelle hängen - aber ich will im selben Script insgesammt 6 Diagramme und 6 Tabellen in das Blatt einfügen.
Echt - danke sehr im Voraus!
Dennis.
AW: Mal gehts - mal wieder nicht
06.04.2020 19:20:28
Dennis
Also ich weiß zwar noch immer net wo der Fehler her kommt - aber es ist IMMER so (gewesen bisher) dass wenn ich einfach auf WEITER klicke im Debugger, dass es dann auch voll durch läuft.
Zur Info das aktuelle Skript:
Sub Outputmodul()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-1").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture) 'copy charts
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E10")) 'paste as  _
pictures
'________________
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-2").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture) 'copy charts
If Err.Number = 0 Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("V10")) 'paste as  _
pictures
'________________
Do
Call Worksheets("PainPoint_tables").Range("Tabelle10[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
DoEvents
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM10"))
'________________
Do
Call Worksheets("PainPoint_tables").Range("Tabelle11[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
DoEvents
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("BX10"))
Application.CutCopyMode = False
Sheets("Output").Select
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 19:26:31
Nepumuk
Hallo Dennis,
ich habe es befürchtet. Excel hat seit der Version 2013 Probleme beim kopieren und einfügen. Also:
On Error Resume Next
Do
    Call Worksheets("PainPoint_tables").Range("Tabelle10[#All]").CopyPicture
    If Err.Number = 0 Then Exit Do
    Call Err.Clear
    DoEvents
Loop
Do
    Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM10"))
    If Err.Number = 0 Then Exit Do
    Call Err.Clear
    DoEvents
Loop
On Error GoTo 0
Application.CutCopyMode = False

Gruß
Nepumuk
Anzeige
AW: Mal gehts - mal wieder nicht
06.04.2020 21:57:17
Dennis
Hallo Nepumuk,
super - hab alle umgestellt - und jetzt klappt es toll. Ich danke Dir für Deinen Support! Hoffe ich hab mal Gelegenheit Dir ebenfalls einen Stein in den Garten zu werfen.
Für alle anderen anbei der Code - klappt super.
Sub Outputmodul()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.RefreshAll
Application.CutCopyMode = False
Call DeleteAllPics
'________________
On Error Resume Next
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-1").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E12"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("D_01").ChartObjects("Diagramm 1-2").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("V12"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle10[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM12"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle11[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("BX12"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________________________________________________________________________________
On Error Resume Next
Do
Call Worksheets("D_02").ChartObjects("Diagramm 2-1").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E43"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("D_02").ChartObjects("Diagramm 2-2").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("V43"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle20[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM43"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle21[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("BX43"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________________________________________________________________________________
On Error Resume Next
Do
Call Worksheets("D_03").ChartObjects("Diagramm 3-1").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("E74"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("D_03").ChartObjects("Diagramm 3-2").CopyPicture(Appearance:=xlScreen,  _
Format:=xlPicture)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("V74"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle30[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("AM74"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________
On Error Resume Next
Do
Call Worksheets("PainPoint_tables").Range("Tabelle31[#All]").CopyPicture
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Call Worksheets("Output").Paste(Destination:=Worksheets("Output").Range("BX74"))
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
On Error GoTo 0
'________________________________________________________________________________________
Application.CutCopyMode = False
Sheets("Output").Select
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige