AW: Makrodurchlauf beenden
20.12.2020 10:54:07
nightcab
Bitteschön...
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Range("D1") Range("D2") Then
MsgBox "Falscher Monat!", vbInformation
Cells(ActiveCell.Row, 1).Select
ActiveCell.Value = ""
End If
'########################## Zeiteingabe ohne Doppelpunkt ###############################
If Target.Count > 1 Then Exit Sub
Dim RaBereich As Range ' Bereich der Wirksamkeit
Dim RaZelle As Range ' zur Zeit untersuchte Zelle
Dim InS As Integer ' Variable für Stunde
Dim InM As Integer ' Variable für Minute
' Set RaBereich = Range("Q4") ' Bereich der Wirksamkeit festlegem
' noch mehr Bereiche
Set RaBereich = Union(Range("Y100:Y1900"), Range("Z100:Z1900"), Range("Q4"))
' ActiveSheet.Unprotect "Password" ' Schutz der Tabelle aufheben
Application.EnableEvents = False ' Reaktion auf Zellveränderung abschalten
For Each RaZelle In Range(Target.Address) ' Schleife falls mehr als eine Zelle mit einmal _
verändert
If Not Intersect(RaZelle, RaBereich) Is Nothing Then ' Zelle ist im Bereich der _
Wirksamkeit
With RaZelle
If .Value "" Then
If IsNumeric(.Value) And InStr(.Value, ":") = 0 And _
InStr(.Value, ",") = 0 And Len(RaZelle) 2 Then
InS = Left(.Value, Len(.Value) - 2)
InM = Right(.Value, 2)
Else
' Stunden haben das Primat
' InS = .Value
' InM = 0
' Minuten haben das Primat
InS = 0
InM = .Value
End If
' überprüfen ob Eingabe in ein Datum umgewandelt werden kann
If IsDate(InS & ":" & InM) Then
.NumberFormat = """ ""hh:mm"" Uhr""" ' Zellformat setzen
.Value = InS & ":" & InM ' Zeit in Zelle schreiben
End If
End If
End If
End With
End If
Next RaZelle
' ActiveSheet.protect "Password" ' Schutz der Tabelle aufheben
Application.EnableEvents = True ' Reaktion auf Zellveränderung einschalten
'#################################### Eingabeverkürzung ###################################
Dim Zellbereich As Range
Dim Primut As String
Set Zellbereich = Range("I100:I1900")
Select Case Target
Case "#1"
Primut = "Tag 1"
Case "#2"
Primut = "Tag 2"
Case "#3"
Primut = "Tag 3"
Case Else
Exit Sub
End Select
Target = Primut
End Sub