Bild zu groß, kann nicht abgeschnitten werden
10.12.2013 07:42:01
Benedikt
Nachfolgender Code läuft seit langer Zeit auf Version 2007 und 2010 ohne Probleme. Mir ist bewusst das es keine Programmierung aus der Feder von euch Profis ist (activate und select etc.)aber leider kann ich es nicht besser.
Das File wurde bei einem Kollegen von mir auf der Version 2010 installiert. Auf diesem Rechner erscheint ungefreuter Weise die Fehlermeldung "Bild zu gross, kann nicht abgeschnitten werden". Nach dem zweiten öffnen der Datei und ausführen des Code stürzt Excel ab. Was ist an seiner .14 Version anders als die auf meinem Rechner? Was führt zu dieser Meldung obwohl nicht ein Bild oder Shape in der Mappe ist. Die Datei ist mit 203 KB auch nicht gerade XXL.Ich habe keine Ahnung wo ich suchen könnte.
Für eure Hilfe bin ich euch Dankbar.
Grüsse und schöne Adventszeit, Benedikt
Option Explicit
Const cstrRange As String = "C20:C2000"
Public rng As Range, lngRow As Long, Kalkblatt As Worksheet, neu As Long, Spalte As Long
Public NameMappe As String
Public NummerMappe As Variant
Function Freien_Platz_suchen()
With Workbooks("Tempoff.xlsm").Worksheets("Offerte")
For Each rng In .Range(cstrRange)
If rng = "" Then
If rng.Offset(1, 0) = "" And Not Intersect(rng.Offset(1, 0), .Range(cstrRange)) Is Nothing Then
If rng.Offset(2, 0) = "" And Not Intersect(rng.Offset(2, 0), .Range(cstrRange)) Is Nothing Then
lngRow = rng.Row + 1
Exit For
End If
End If
End If
Next
End With
End Function
Public Function MappeCopy()
NameMappe = Left(Range("C8").Value, 15)
NummerMappe = Workbooks("Tempoff.xlsm").Sheets.Count
NummerMappe = NummerMappe + 1
ActiveSheet.Copy After:=Workbooks("Tempoff.xlsm").Sheets(3)
ActiveSheet.Name = NummerMappe & " " & NameMappe
Sheets("Offerte").Select
End Function
Function Text_einfügen()
With Workbooks("Tempoff.xlsm").Worksheets("Offerte").Cells(lngRow, Spalte)
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
End Function Sub Test()
Freien_Platz_suchen
Application.ScreenUpdating = False
'Titel kopieren
lngRow = lngRow + 1
If lngRow > 0 Then Sheets("Hugo").Range("C8").Copy
Spalte = 3
Text_einfügen
'Nummerierung
Workbooks("Tempoff.xlsm").Worksheets("Offerte").Activate
ActiveCell.Offset(0, -1) = Int(Application.WorksheetFunction.Max(Range(Cells(1, 2), Cells(ActiveCell.Row, 2)))) + 1
Selection.Font.Bold = True
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
'Text einfügen
Freien_Platz_suchen
lngRow = lngRow
If lngRow > 0 Then Sheets("Hugo").Range("C9:C21").Copy
Text_einfügen
'Totalkopieren
Freien_Platz_suchen
lngRow = rng.Row - 1
If lngRow > 0 Then Sheets("Hugo").Range("I8:K8").Copy
Spalte = 8
Text_einfügen
'Arbeitsblatt drucken
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1
'Arbeitsblatt Hugo in Offerte kopieren
MappeCopy
'Übergabe Auswertung an Titelblatt
Workbooks("Tempkalk.xlsm").Worksheets("Hugo").Activate
Range("O4:AC4").Select
Selection.Copy
Workbooks("Tempoff.xlsm").Worksheets("Titel").Activate
Range("A26").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Rows("26:26").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("A27:M27").Select
With Selection.Font
.Name = "Arial"
.Size = 8
End With
Range("C27:M27").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
Selection.NumberFormat = "0.00"
End With
Range("A100").Select
Sheets("Offerte").Select
ActiveWorkbook.Save
Windows("Tempkalk.xlsm").Activate
Application.ScreenUpdating = True
MsgBox "Kalkulation I.O "
End Sub