Drucken nach Zellenabfrage

Private Sub Workbook_BeforePrint(Cancel As Boolean)
 If Not TesteVorDruckenZelleAufZahl(ActiveSheet) Then Cancel = True
End Sub
'===========================================================================
Private Function TesteVorDruckenZelleAufZahl(ws As Worksheet) As Boolean
'*** gibt für nicht zu überwachende Blätter true zurück
 
 Dim bBlattUeberwacht As Boolean
 Dim x As Long
 
 TesteVorDruckenZelleAufZahl = True
 
 Dim TabellenBlattNamen As Variant
 TabellenBlattNamen = Array(Tabelle1, Tabelle2, Tabelle3)-><-- hier Blattnamen anpassen
 Const c_ueberwachterZellRange = I5
 
->Ist das Blatt überwacht ?
 For x = LBound(TabellenBlattNamen) To UBound(TabellenBlattNamen)
  If ws.Name = TabellenBlattNamen(x) Then bBlattUeberwacht = True: Exit For
 Next
 If Not bBlattUeberwacht Then Exit Function

->ist in der überwachten Zelle keine Zahl ?
 If Not ((ws.Range(c_ueberwachterZellRange).Value <> ) And _
   (IsNumeric(ws.Range(c_ueberwachterZellRange).Value))) Then
  TesteVorDruckenZelleAufZahl = False
  MsgBox  & c_ueberwachterZellRange &  auf Blatt  & ws.Name &  enthält keine Zahl.
 End If
   
End Function

Option Explicit

Sub Workbook_BeforePrint(Cancel As Boolean)
 
 Const cRANGE_DATUM = M1
 Const cFORMAT_DATUM = d. mmmm yyyy
 Const cRANGE_MIETVERTRAGNT = I5
 
 Dim s As String
 Dim Zelle As Range
 
 Set Zelle = ActiveSheet.Range(cRANGE_DATUM)
 If Not DatumPruefen(Zelle, cFORMAT_DATUM) Then
  Cancel = True
  GoTo AUFRAEUMEN
 End If
 
 
 Zelle = ActiveSheet.Range(cRANGE_MIETVERTRAGNT)
 If Zelle.Value =  Then
  s = InputBox(Mietvertrag Nt. eintragen! ! !)
  If s =  Then Cancel = True: GoTo AUFRAEUMEN
  Zelle = s
 End If
AUFRAEUMEN:
 Set Zelle = Nothing
End Sub

Private Function DatumPruefen(Zelle As Range, sFormat As String) As Boolean
 
 Dim s As String, sZusatz As String, sEingabe As String
 Dim sTag As String, sMonat As String, sJahr As String
 Dim lTag As Long, lMonat As Long, lJahr As Long, pos As Long
 Dim ddate As Date
 
 If IsDate(Zelle.Value) Then
  DatumPruefen = True
  Exit Function
 End If
 
 Do
NOCHMAL:
  s = InputBox( _
   Bitte Datum eingeben: & vbLf & (t.m oder t.m.yy oder t.m.yyyy) & _
   vbLf & vbLf & sZusatz, _
   Eingabe Datum, _
   s)
  
  If s =  Then Exit Function->Abbruch
  
  sEingabe = s: sTag = : sMonat = : sJahr = 
  
 ->*** Tag ***
  pos = InStr(1, sEingabe, .)
  If pos < 1 Then sZusatz = Angabe Tag ungültig.: GoTo NOCHMAL
  sTag = Left(sEingabe, pos - 1)
  sEingabe = Right(sEingabe, Len(sEingabe) - pos)->Tag aus Eingabe abschneiden
  On Error Resume Next
  lTag = sTag
  If Err.Number <> 0 Then
   Err.Clear: On Error GoTo 0
   sZusatz = Angabe Tag ungültig.: GoTo NOCHMAL
  End If
  On Error GoTo 0
  
 ->*** Monat ***
  pos = InStr(1, sEingabe, .)
  If pos < 1 Then
   sMonat = sEingabe
   sEingabe = 
  Else
    sMonat = Left(sEingabe, pos - 1)
   sEingabe = Right(sEingabe, Len(sEingabe) - pos)
  End If
  On Error Resume Next
  lMonat = sMonat
  If Err.Number <> 0 Then
   Err.Clear: On Error GoTo 0
   sZusatz = Angabe Monat ungültig.: GoTo NOCHMAL
  End If
  On Error GoTo 0
 
 ->*** Jahr ***
  sJahr = sEingabe
  If Len(sJahr) = 0 Then sJahr = Format(Now(), yyyy)
  On Error Resume Next
  lJahr = sJahr
  If Err.Number <> 0 Then
   Err.Clear: On Error GoTo 0
   sZusatz = Angabe Jahr ungültig.: GoTo NOCHMAL
  End If
  On Error GoTo 0
  If lJahr < 100 Then lJahr = lJahr + 2000
  
 ->*** Wertebereiche prüfen
  On Error Resume Next
  ddate = lTag & . & lMonat & . & lJahr
  If Err.Number <> 0 Then
   Err.Clear: On Error GoTo 0
   sZusatz = Datum ungültig.: GoTo NOCHMAL
  End If
  On Error GoTo 0
  If (Day(ddate) <> lTag) Or _
    (Month(ddate) <> lMonat) Or _
    (lJahr > 2039) Then
   sZusatz = Datum ungültig.: GoTo NOCHMAL
  End If
  
 ->*** Zelle formatieren und Datum eintragen
  Zelle.NumberFormat = sFormat
  Zelle.Value = ddate
  Exit Do
  
 Loop
 
 DatumPruefen = False
 
End Function