folgende Situation:
Tabelle1 besteht aus verschiedenen Informationen (Hier geht es um zwei Spalten davon).
Spalte (A) Das Datum
Spalte (C) Die Uhrzeit
Situation:
Es sollen nur maximal 10 Zeiteingaben zu jeder Stunde zulässig sein.
Zum Beispiel: Datum: 04.04.2022
Zeiteingaben: 10:00, 10:00, 10:00,...............................10:00 (10 X), falls weitere Eingabe (Nr. 11) für diese Uhrzeit gemacht wird, soll durch eine Meldung
eine Warnung herausgegeben werden und anschließend soll die Routine zur Subroutine (Eingabe) zurückkehren!
Mein Problem besteht darin, dass die Routine schon bei der Eingabe vom Datum aber auch Uhrzeit, erkennen muss, ob schon eine weitere Uhrzeit
zu diesem Datum zulässig ist oder nicht!
Das heißt ungefähr so, dass die ComboBox_Datum und TextBox_Uhrzeit mit Daten aus der Tabelle befüllt werden müssen, dann werden diese Daten
mit der Neueingabe verglichen und die Routine erkennt auch die Zulässigkeit oder auch nicht, danach erfolgt die Meldung!!!!!!!
Mein Code, um die Tabelle1 mit Daten zu versorgen:
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
'Bildschirmauflösung des Bildschirms an dem die Userform erstellt wurde
Const LHorizontale As Long = 1920
Const LVertikal As Long = 1080
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
ThisWorkbook.RefreshAll
Application.EnableEvents = True
End Sub
Private Sub CommandButton5_Click()
Unload UF_VB_Aufnehmen
End Sub
Private Sub CommandButton2_Click()
Dim Last As Integer
Last = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Tabelle1").Cells(Last, 1).Value = ComboBox_Datum.Value
Worksheets("Tabelle1").Cells(Last, 3).Value = TextBox_Uhrzeit.Value
Worksheets("Tabelle1").Cells(Last, 7).Value = TextBox_Name
If ComboBox_Außerhalb.Value = "" Then
Worksheets("Tabelle1").Cells(Last, 8).Value = "Flensburg"
Else
Worksheets("Tabelle1").Cells(Last, 8).Value = ComboBox_Außerhalb.Value
End If
Worksheets("Tabelle1").Cells(Last, 19).Value = ComboBox_A.Value
Worksheets("Tabelle1").Cells(Last, 20).Value = TextBox_HausNr
Worksheets("Tabelle1").Cells(Last, 10).Value = ComboBox_Bemerkungen
Worksheets("Tabelle1").Cells(Last, 21).Value = TextBox_PKWBUS
Worksheets("Tabelle1").Cells(Last, 12).Value = TextBox_Vorlaufzeit.Value
'Aktualisierung der Tabelle1
With Worksheets("Tabelle1")
.Range("A2:N20000").Sort Key1:=.Range("N1"), order1:=xlAscending, Header:=xlNo, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub
Private Sub CommandButton6_Click()
With Columns("A:AK")
.Sort Key1:=Range("K1"), Key1:=Range("L1"), Header:=xlYes
End With
End Sub
Private Sub UserForm_Initialize()
'Befüllen
With Worksheets("FlensburgerStrassen")
ComboBox_A.List = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 1)).Value
End With
ComboBox_A.ListIndex = 1
'Datum (ComboBox-Datum, befüllen
Dim Datum As Long
For Datum = CLng(CDate("14.12.2020")) To CLng(CDate("31.12.2050"))
UF_VB_Aufnehmen.ComboBox_Datum.AddItem CDate(Datum)
Next Datum
UF_VB_Aufnehmen.ComboBox_Datum.ListIndex = CLng(Now) - 1 - CLng(CDate("14.12.2020"))
'Befüllen ComboBox_Bemerkungen
With Worksheets("Bemerkungen")
ComboBox_Bemerkungen.List = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 1)).Value
End With
ComboBox_Bemerkungen.ListIndex = 1
'Befüllen ComboBox_Außerhalb
With Worksheets("Außerhalb")
ComboBox_Außerhalb.List = .Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, 1)).Value
End With
ComboBox_Außerhalb.ListIndex = 1
'Anzeigen ListBox1
Dim lLetzte1 As Long
Application.ScreenUpdating = False
ListBox1.Clear
With Range("Tabelle1!A2:K2")
With Worksheets("Tabelle1")
lLetzte1 = .Cells(Rows.Count, 1).End(xlUp).Row
With Me.ListBox1
.ColumnCount = 11
' ListBox1.Selected(0) = True
.ColumnHeads = False
.Font.Size = 19
ListBox1.RowSource = "Tabelle1!A2:K2" & lLetzte1
End With
End With
Application.ScreenUpdating = True
ListBox1.ColumnWidths = "3,3 Cm;0,5 Cm;2,3 Cm;2,5 Cm;4,5 Cm;4,5 Cm;6,0 Cm;6,0 Cm;8,5 Cm;9,0 Cm;1,5 Cm"
End With
Private Sub TextBox_Uhrzeit_Afterupdate()
Dim tString As String
Dim tDate As Date
On Error GoTo ErrMsg
With TextBox_Uhrzeit
'Check if user put in a colon or not
If InStr(1, .Value, ":", vbTextCompare) = 0 Then
'If not, make string 4 digits and insert colon
tString = Format(.Value, "0000")
tDate = TimeSerial(Left(tString, 2), Right(tString, 2), 0)
TextBox_Uhrzeit.Value = Format(tDate, "HH:MM")
Else
'Otherwise, take value as given
.Value = Format(.Value, "hh:mm")
End If
End With
Exit Sub
ErrMsg:
MsgBox "Oops! Etwas läuft völlig falsch.", vbOKOnly, "Unexpected entry"
End Sub
Private Sub CommandButton40_Click()
Dim rngCell As Range
Dim strFirstAddress As String
With Worksheets("FlensburgerStrassen").Range("A:A")
Me.ComboBox_A.Clear.Contents
Set rngCell = .Find(Me.TextBox1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngCell Is Nothing Then
strFirstAddress = rngCell.Address
Do
With Me.ComboBox_A
.ColumnCount = 1
.AddItem
.List(.ListCount - 1, 0) = rngCell.Value
.List(.ListCount - 1, 1) = rngCell.Offset(0, 1).Value
End With
Set rngCell = .FindNext(rngCell)
Loop While Not rngCell Is Nothing And rngCell.Address strFirstAddress
Else
MsgBox "Adresse nicht gefunden", 48
End If
End With
End Sub
Private Sub CommandButton41_Click()
Dim wks As Worksheet
Set wks = Worksheets("Tabelle1")
With Me.ComboBox_A
wks.Range("A6").Value = .List(.ListIndex, 0)
End With
End Sub
Kann mir jemand bitte helfen
Ich bin euch sehr dankbar für Eure Vorschläge
Viele Grüße
Nader