Option Explicit
'Schaltfläche (Button) verweist auf dieses Makro
Sub ChkBeforeSave()
Const OrdnerPfad As String = "y:\Nachkalkulation\" 'ggf. ändern
Const PfadZelle As String = "C1" '
Const KdNrZelle As String = "E1" '
'
Dim flag, chk 'alles richtig?
Dim strFullname As String 'speichern als
'
On Error GoTo Fehler
'Prüfung auf OrdnerPfad in Pfadzelle
With Range(PfadZelle)
chk = .Value * 1
If Len(Trim(.Formula)) = 8 Then flag = True
End With
'Prüfung auf Kundennummer in KdNrZelle
With Range(KdNrZelle)
chk = .Value * 1
If Len(Trim(.Formula)) <> 5 Then flag = False
End With
On Error GoTo 0
Fehler:
'Auswerten
Select Case Err.Number
Case 0
If flag = True Then
On Error GoTo LW
Application.DisplayAlerts = False
strFullname = OrdnerPfad & Format(Range(PfadZelle).Formula, String(8, "0")) & ".xlsx"
ActiveWorkbook.SaveAs Filename:=strFullname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
On Error GoTo 0
Else
Call MsgBox("Eingabelängen in " & _
"PfadZelle" & " bzw. " & "KdNrZelle" & " prüfen!", vbExclamation, "Abbruch")
End If
Case 13
Call MsgBox("Eingaben in " & _
"PfadZelle" & " bzw. " & "KdNrZelle" & " sind keine Ziffern!", vbExclamation, "Abbruch")
Case Else
Call MsgBox("Unbekannter Fehler!", vbExclamation, "Abbruch")
End Select
LW:
If Err.Number = 1004 Then _
Call MsgBox("Speicherpfad?" & Chr(10) & "Einstellungen im Makro prüfen!", vbExclamation, "Abbruch")
Application.DisplayAlerts = True
End Sub
|