Das Bild ist zu gross und wird abgeschnitten

Hallo zusammen
Seit einiger Zeit erhalte ich beim Schliessen einer Datei die Fehlermeldung "Das Bild ist zu gross und wird abgeschnitten" immer dann, wenn ich vorgängig folgendes Makro ausgelöst habe:
Sub Handlungsbedarf_alle_Infrastrukturanlagen()
'Fehlermeldung
On Error GoTo out
GetMoreSpeed True
'*****************************allgemeiner Teil************************************
Blattname = "Infra Gesamt"
With Worksheets("Master Datei")
Spalte_P_RV_IK = .Application.Match("Infra-Koo P", .Rows(1), 0)
Spalte_Nutzlänge = .Application.Match("Perronnutzlänge", .Rows(1), 0)
Spalte_P_Länge = .Application.Match("Handlungsbedarf Perronnutzlänge", .Rows(1), 0)
Spalte_P_Höhe = .Application.Match("Handlungsbedarf Perronhöhe", .Rows(1), 0)
Spalte_treppenfrei = .Application.Match("Handlungsbedarf treppenfreier Zugang", .Rows(1), 0)
'---Jahr unlogisch
If Jahr1 = "" Or Jahr2 = "" Or Jahr2 MsgBox prompt:="Auswahl unlogisch, bitte gewählte Jahre überprüfen", _
Title:=" Hinweis an " & Application.UserName
GetMoreSpeed False
End
End If
'--- eruiert letzte Zeile/Spalte
intlastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
intLastRow = .Cells(Rows.Count, Spalte_Nutzlänge).End(xlUp).Row
End With
'*** Loop 1 Beginn
Application.DisplayAlerts = False
'--- löscht Blatt wenn vorhanden
For Each Blatt In ActiveWorkbook.Sheets
If Blatt.Name = Blattname Then
Worksheets(Blatt.Name).Delete
End If
Next Blatt
Application.DisplayAlerts = True
'*** Loop 1 Ende
'--- blendet Blatt Vorlage ein
Worksheets("Vorlage").Visible = xlSheetVisible
'--- kopiert Blatt Vorlage nach Blatt "Pilot"
Worksheets("Vorlage").Copy After:=Sheets(Sheets.Count)
Worksheets("Vorlage (2)").Name = Blattname
'--- blendet Blatt Vorlage definitv aus
Worksheets("Vorlage").Visible = xlVeryHidden
'***************************Ende allgemeiner Teil********************************
Call alle
With Worksheets(Blattname)
'--- prüft ob auf Blatt 'Blattname' Einträge vorhanden
intLastRow = .Cells(Rows.Count, Spalte_Nutzlänge).End(xlUp).Row
If intLastRow Application.DisplayAlerts = False
'--- löscht Blatt 'Blattname'
.Delete
Application.DisplayAlerts = True
MsgBox prompt:="Es ist kein Handlungsbedarf für Infrastrukturbauten" _
& vbLf & "gemäss Ihren Kriterien aufgeführt", _
Title:=" Info an " & Application.UserName
Worksheets("Pilot").Select
' Unload usrMaster_Warten
GetMoreSpeed False
Exit Sub
End If
'---löscht Spalten "i"
Spalte_Info_Muster = .Application.Match("Detail-Info Muster", .Rows(1), 0)
.Columns(Spalte_Info_Bahnhof).Delete
Spalte_Info_Roma = .Application.Match("Detail-Info Roma", .Rows(1), 0)
.Columns(Spalte_Info_Roma).Delete
Spalte_Info_Perron = .Application.Match("Detail-Info Perron", .Rows(1), 0)
.Columns(Spalte_Info_Perron).Delete
Spalte_Info_KI = .Application.Match("Detail-Info KI", .Rows(1), 0)
.Columns(Spalte_Info_KI).Delete
Spalte_Einsatz_FVRoma = .Application.Match("Planung FV-Roma-Einsatz", .Rows(1), 0)
.Columns(Spalte_Einsatz_FVRoma).Delete
Spalte_Einsatz_RVRoma = .Application.Match("Planung RV-Roma-Einsatz", .Rows(1), 0)
.Columns(Spalte_Einsatz_RVRoma).Delete
Spalte_Info_Handlungsbedarf = .Application.Match("Handlungsbedarf", .Rows(1), 0)
.Columns(Spalte_Info_Handlungsbedarf).Delete
'--- löscht alle Shapes
.DrawingObjects.Delete
'---eruiert Spalten-Buchstabe von DIDOK
Spalte_DIDOK = .Application.Match("DIDOK", .Rows(1), 0)
Ziel = Application.Substitute(Cells(1, Spalte_DIDOK - 1).Address(0, 0), 1, "")
'--- löscht Spalten B bis J
.Columns("B:" & Ziel).Delete Shift:=xlToLeft
.Cells.EntireColumn.AutoFit
End With
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Application.StatusBar = False
GetMoreSpeed False
Exit Sub
out:
MsgBox prompt:="Fehler Nummer " & Err.Number & " ist aufgetreten in" _
& vbNewLine & "Sub Handlungsbedarf_alle_Infrastrukturanlagen()" _
& vbNewLine & vbNewLine & "Die Ausführung wird beendet" _
& vbNewLine & "Wenden Sie sich an den Ersteller", _
Title:=" Fehlermeldung"
Worksheets("Pilot").Select
GetMoreSpeed False
End Sub Sub alle()
With Worksheets("Master Datei")
intLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Zeile = 6 To intLastRow
Handlungsbedarf = False
Muster = .Cells(Zeile, 1).Value
If Muster = "" Then
Muster = .Cells(Zeile, 1).End(xlDown).Value
Zeile = .Cells(Zeile, 1).End(xlDown).Row
End If
ZeileEnd = IIf(IsEmpty(.Cells(Zeile + 1, 1)), IIf(IsEmpty(.Cells(.Cells(Zeile, 1).End(xlDown).Row - 1, Spalte_Nutzlänge)), .Cells(.Cells(Zeile, 1).End(xlDown).Row, Spalte_Nutzlänge).End(xlUp).Row, .Cells(Zeile, 1).End(xlDown).Row - 1), Zeile)
'--- eruiert zu durchsuchenden Bereich Jahre
Set rng4 = Union( _
.Range(.Cells(Zeile, Spalte_P_Länge), .Cells(ZeileEnd, Spalte_P_Länge)), _
.Range(.Cells(Zeile, Spalte_P_Höhe), .Cells(ZeileEnd, Spalte_P_Höhe)), _
.Range(.Cells(Zeile, Spalte_treppenfrei), .Cells(ZeileEnd, Spalte_treppenfrei)))
'---Handlungsbedarf alle Jahre
If Jahr1 = "alle Jahre" And Jahr2 = "alle Jahre" Then
If WorksheetFunction.CountA(rng4) > 0 Then Handlungsbedarf = True
Else
'---Handlungsbedarf ausgewählte Jahre
For Each d In rng4.Cells
If d.Value >= Jahr1 * 1 And d.Value Handlungsbedarf = True
Exit For
End If
Next
End If
If Handlungsbedarf = True Then
'--- eruiert zu durchsuchenden Bereich Priorität
Set rng5 = Union( _
.Range(.Cells(Zeile, Spalte_P_Länge + 3), .Cells(ZeileEnd, Spalte_P_Länge + 3)), _
.Range(.Cells(Zeile, Spalte_P_Höhe + 3), .Cells(ZeileEnd, Spalte_P_Höhe + 3)), _
.Range(.Cells(Zeile, Spalte_treppenfrei + 2), .Cells(ZeileEnd, Spalte_treppenfrei + 2)))
Prio = False
Select Case Priorität
'Priorität 3
Case 3
For Each z In rng5.Cells
If z.Value = 3 Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität 2
Case 2
For Each z In rng5.Cells
If z.Value = 2 Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität 1
Case 1
For Each z In rng5.Cells
If z.Value = 1 Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität 1 / 2 / 3
Case Is = "1 / 2 / 3"
For Each z In rng5.Cells
If z.Value = 3 Or z.Value = 2 Or z.Value = 1 Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität S
Case Is = "S"
For Each z In rng5.Cells
If z.Value = "S" Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität MUP
Case Is = "MUP"
For Each z In rng5.Cells
If z.Value = "MUP" Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität P
Case Is = "P"
For Each z In rng5.Cells
If z.Value = "P" Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
'Priorität MUP / P
Case Is = "MUP / P"
For Each z In rng5.Cells
If z.Value = "MUP" Or z.Value = "P" Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
Case Else
For Each z In rng5.Cells
If z.Value = 3 Or z.Value = 2 Or z.Value = 1 Or z.Value = "S" Or z.Value = "MUP" Or z.Value = "P" Then
Zeile = z.Row
Prio = True
Exit For
End If
Next
End Select
If Prio = True Then
'--- prüfen, ob eruierte Zeile der obersten Zeile Bahnhof entspricht
If IsEmpty(.Cells(Zeile, 1)) And IsEmpty(.Cells(Zeile, 2)) = True Then
Zeile = .Cells(Zeile, 1).End(xlUp).Row
End If
'----- Zeilen kopieren
'--- bestimmt letzte Zeile Tabelle zum Einfügen
intLastRowPaste = Worksheets(Blattname).Cells(Rows.Count, Spalte_Nutzlänge).End(xlUp).Row + 1
.Range(.Cells(Zeile, 1), .Cells(ZeileEnd, intlastColumn)).Copy Worksheets(Blattname).Cells(intLastRowPaste, 1)
End If
End If
Application.StatusBar = "Fortschrittskontrolle: " & intLastRow - ZeileEnd - 4
Next
End With
Application.StatusBar = False
End Sub Das Makro erstellt eine zusätzliche Tabelle, die beim Schliessen mit folgendem Makro gelöscht _
wird:


Private Sub Workbook_BeforeClose(Cancel As Boolean)
GetMoreSpeed True
'unnötige Blätter löschen
If Worksheets.Count > 4 Then
For Each sh In ThisWorkbook.Worksheets
If sh.Name  "Muster" Then sh.Delete
Next
End If
End Sub

Kann mir jemand sagen, wie ich das beheben kann? Übirgens, das Makro läuft fehlerlos.
Vielen Dank und Gruss
Gregor

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo zusammen
Ich habe im Internet folgende interessante Lösung gefunden:
Problem:
Beim schließen von Excel mittels Makro bekommt man den Hinweis: "Bild zu groß, kann nicht abgeschnitten werden".
Das Problem ist die Zwischenablage, die noch "voll" ist.
Man möchte nun mittels VBA-Makro die Zwischenablage löschen
Lösung:
Folgendes Makro in den Bereich "Arbeitsmappe" kopieren

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ClearClipboard
End Sub

Public Sub ClearClipboard()
OpenClipboard 0&
EmptyClipboard
CloseClipboard
End Sub

Unter "Dekleration" im Modul:
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard& Lib "user32" ()
Danke und Gruss
Gregor

Beliebteste Forumthreads (12 Monate)

Das Bild ist zu gross und wird abgeschnitten

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

2 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Das Bild ist zu gross und wird abgeschnitten

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

2 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread