AW: Excel stürzt am Ende des Makros ab
19.10.2014 13:47:28
Endi
Hi Boris,
ich wollte nur nicht gleich mit der Tür ins Haus fallen.
Hier ist mein Code
Sub KundenSpeichern_WeitererKunde()
'Speicherung des Kunden, Eintrag in Kundenliste, Datei schließen,Blanko neu öffnen
'Application.ScreenUpdating = False
Dim Pfad As Variant, Datei As Variant
Pfad = Range("B1")
Datei = Range("D1")
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Call Weiter 'KU4_Weiter
'
Sub Weiter()
'Kundenblatt einrichten und speichern
Dim Speicherort As Variant, Datei As Variant
Datei = Range("D1")
Speicherort = Range("C1")
ActiveSheet.Unprotect ("#")
ActiveSheet.Shapes("Blende1").Visible = False
ActiveSheet.Shapes("Suchfunktion").Visible = False
ActiveSheet.Shapes("Weiter").Visible = True
ActiveSheet.Shapes("DatenÄndern").Visible = False
ActiveSheet.Shapes("KdSpeichernWeiter").Visible = True
ActiveSheet.Shapes("Weiter").Visible = True
Range("F1") = "Kundenblatt" 'Als Kundenblatt indizieren
ActiveSheet.Protect ("#")
Stop
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
' Call Sicherungskopie 'Legt eine Sicherungskopie an und kehrt herher zurück
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Call KundenlisteErgänzen 'Modul Kundeliste aufrufen und dort Kunden eintragen
'
Sub KundenlisteErgänzen()
'Wechsel zum Tabellenblatt Kundenliste in der _
Startdatei___________________________________________________________________________
Dim Datei As Variant
Datei = Range("D1")
Windows("Kundendatei.xlsm").Activate
Sheets("Kundenliste").Visible = True 'Kundenliste aufrufen
Sheets("Kundenliste").Select
ActiveSheet.Unprotect "#"
Application.CutCopyMode = False
If ActiveSheet.FilterMode = True Then 'Klärung ob Autofilter schon gesetzt, dann löschen
ActiveSheet.ShowAllData ' _
eventuell Filtermodus löschen
ActiveSheet.Protect "#", DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlNoRestrictions
End If
'Übernahme der Adressdaten aus der neuangelegten _
Kundendatei__________________________________________________________________________________________
'Datei des Kunden aktivieren
Workbooks(Datei).Activate
Range("C8:C12").Select
Selection.Copy
Workbooks("Kundendatei.xlsm").Sheets("Kundenliste").Activate 'Kundenliste für Neueintrag _
positionieren
'ActiveSheet.ShowAllData
Range("A5").Select _
'Unterste Zeile suchen
Cells.Find(What:=Range("A1"), After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 1).Select
ActiveSheet.Unprotect "#"
Stop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False
ActiveCell.Offset(0, -1).Range("A1:G1").Select 'Zeile markieren und Linie ziehen
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
End With
ActiveCell.Offset(0, 6).Range("A1") = Range("G1") 'Datum eintragen
ActiveCell.Offset(0, 0) = Range("A1") + 1 ' _
Lfd Nr für Neukunden hochzählen
Range("A1") = ActiveCell _
'und Suchparameter in Zelle A1anpassen
ActiveCell.Offset(0, 0).Select _
'Aktive Zelle an den Rand neben letzem Eintrag positionieren
Application.CutCopyMode = False 'Kopie aktivierte Zellen _
deaktivieren
Sheets("Startseite").Select
Sheets("Kundenliste").Visible = False
Stop
'Über Modul: Ku4_Weiter zum Blanko zurück >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If Workbooks(Datei).Sheets("Behandlung").Range("F1") = "Kundenblatt" Then Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Stop
Range("C8:C9").Select 'Startseite leeren
Selection.ClearContents
Range("C8").Select
End Sub