Absturz in 2010
Benedikt
Nachfolgender Code erledigte unter 2003 und 2007 seinen Dienst ohne beanstandung. Allerdings waren die beiden Dateien anzusprechenden Dateien noch als .xls angesprochen worden.
Derzeit baue ich alles auf .xlsm um, also installierte ich auch noch die neue Excelversion 2010.
Jetzt kommt der schwierige Teil: Excel 2010 stürzt beim Ausführen des Code in unregelmässigen Abständen ab. Manchmal haut es 10 x , manchmal nur 1 x. Excel verabschiedet sich gnadenlos mit der Meldung "Excel funktioniert nicht". Wie gesagt, der Code tut seinen Dienst auf den Vorgängerversionen seit Jahr und Tag und das schwere ist, dass es keinen klaren indikator für den Absturz gibt. Nach subjektivem Bauchgefühl glaube ich das die eingebaute Function "Mappe Copy" der auslöser ist. (Die Funktion fügt das aktuelle Kalkulationsblatt aus Datei Tempkalk in die Datei Tempoff ein).
Bei meiner Suche im Web bin ich auf ähnliche Probleme im Zusammenhang mit Abstürzen beim kopieren von Arbeitsmappen gestossen, habe aber keine Lösung gefunden.
Vielen Dank wenn mir jemand weiterhilft
Option Explicit
Const cstrRange As String = "C21: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 Text_einfügen()
With Workbooks("Tempoff.xlsm").Worksheets("Offerte").Cells(lngRow, Spalte)
.PasteSpecial Paste:=xlValues
End With
Application.CutCopyMode = False
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 Freien_Platz_suchen1()
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 Sub Hugoklein()
Freien_Platz_suchen1
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) = Application.WorksheetFunction.Max(Range(Cells(1, 2), Cells(ActiveCell.Row, 2))) + 0.1
Selection.Font.Italic = True
Selection.Font.Underline = xlUnderlineStyleSingle
Workbooks("Tempzubehör.xlsm").Worksheets("HUGO").Activate
'Text einfügen
Freien_Platz_suchen1
lngRow = lngRow - 1
If lngRow > 0 Then Sheets("HUGO").Range("C9:C21").Copy
Text_einfügen
'Totalkopieren
Freien_Platz_suchen1
lngRow = rng.Row - 1
If lngRow > 0 Then Sheets("HUGO").Range("I8:K8").Copy
Spalte = 8
Text_einfügen
'Arbeitsblatt Hugo in Offerte kopieren
MappeCopy
'Übergabe Auswertung an Titelblatt
Workbooks("Tempzubehör.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
'Wenn keine Tempkalk offen:
On Error Resume Next
Windows("Tempkalk.xlsm").Activate
If Err 0 Then
Err.Clear
End If
On Error GoTo 0
Application.ScreenUpdating = True
MsgBox "Kalkulation I.O "
Application.DisplayAlerts = False
Windows("Tempzubehör.xlsm").Close
Application.Run "Material.xlsm!Türenzubehördialog"
End Sub