hier mein derzeitiger Stand und ja die Suche findet nichts am heutigen Tag.
Code:
Private Sub UserForm_Initialize()
InitializeCboTherapist
InitializeCboCustomer
InitializeLstResponse
Me.txtSearchDate = Date
Me.txtCount = 100
Me.chkPartialResult = True
End Sub
Private Sub UserForm_Terminate()
If lstResponse.Tag <> "" Then
Range(lstResponse.Tag).Interior.ColorIndex = 4
Cells(8, Range(lstResponse.Tag).Column).Interior.ColorIndex = 2
Cells(Range(lstResponse.Tag).Row, 1).Interior.ColorIndex = 43
Cells(Range(lstResponse.Tag).Row, 2).Interior.ColorIndex = 19
End If
End Sub
Private Sub InitializeCboTherapist()
Dim i As Long
Me.cboTherapist.Clear
With Sheets("Parameter")
For i = 3 To 10
If Not .Cells(i, 1) = Empty Then Me.cboTherapist.AddItem .Cells(i, 1)
Next
End With
End Sub
Private Sub InitializeCboCustomer()
Dim i As Long
Me.cboCustomers.Clear
With Sheets("Patienten")
For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
Me.cboCustomers.AddItem .Cells(i, 1) & " " & .Cells(i, 2)
Next
End With
End Sub
Private Sub InitializeLstResponse()
With Me.lstResponse
.Clear
.ColumnCount = 7
.BoundColumn = 1
.ColumnWidths = "0cm;6cm;1,8cm;3cm;3,3cm;2,3cm;3cm"
End With
End Sub
Private Sub cmdAcceptSearch_Click()
SearchAppointmentsWithCustomerData_CheckSearchString
End Sub
Private Sub cmdSearchAppointments_Click()
SearchAppointments_CheckSearchString
End Sub
Private Sub txtSearchAppointments_AfterUpdate()
SearchAppointments_CheckSearchString
End Sub
Private Sub txtSearchAppointments_Change()
If Me.lstResponse.ListCount > 0 Then Me.lstResponse.Clear
End Sub
Private Sub txtCount_Change()
If Me.lstResponse.ListCount > 0 Then Me.lstResponse.Clear
End Sub
Private Sub txtSearchDate_Change()
If Me.lstResponse.ListCount > 0 Then Me.lstResponse.Clear
End Sub
Private Sub cboTherapist_Change()
If Me.lstResponse.ListCount > 0 Then Me.lstResponse.Clear
End Sub
Private Sub txtCount_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Me.txtCount.Text = Empty Then Me.txtCount = 100
If Not IsNumeric(Me.txtCount) Then Me.txtCount = 100
End Sub
Private Sub txtSearchDate_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Me.txtSearchDate <> Empty Then
If Not IsDate(Me.txtSearchDate) Then
Beep
Cancel = True
Else
Me.txtSearchDate.Text = Format(DateSerial(Sheets("Januar").Range("A1"), Month(Me.txtSearchDate), Day(Me.txtSearchDate)), "DD.MM.YYYY")
End If
End If
End Sub
Private Sub cboTherapist_AfterUpdate()
SearchAppointments Me.txtCount, Me.txtSearchDate, True, Me.cboTherapist
End Sub
Private Sub cmdSearchFreeAppointments_Click()
SearchAppointments Me.txtCount, Me.txtSearchDate, True, Me.cboTherapist
End Sub
Private Sub SearchAppointmentsWithCustomerData_CheckSearchString()
If Len(Me.cboCustomers) = 0 Then
MsgBox "Bitte einen Kunde auswählen.", vbInformation, "fehlende Eingabe"
Exit Sub
End If
SearchAppointments 500, DateSerial(Sheets("Januar").Range("A1"), 1, 1), False, , Me.cboCustomers, CBool(Me.chkPartialResult)
If Me.lstResponse.ListCount = 0 Then
MsgBox "Keine Termine vorhanden", vbInformation, "Information"
End If
End Sub
Private Sub SearchAppointments_CheckSearchString()
If Len(Me.txtSearchAppointments.Text) = 0 Then 'Textbox leer ??
MsgBox "Bitte Suchtext eingeben", vbInformation, "fehlende Eingabe"
Exit Sub
End If
SearchAppointments 500, DateSerial(Sheets("Januar").Range("A1"), 1, 1), False, , Me.txtSearchAppointments, CBool(Me.chkPartialResult)
If Me.lstResponse.ListCount = 0 Then
MsgBox "Keine Termine vorhanden", vbInformation, "Information"
End If
End Sub
Private Sub SearchAppointments(ByVal AppointmentsCount As Long, _
ByVal SearchDate As Date, _
ByVal SearchFreeAppointments As Boolean, _
Optional ByVal Therapist As String = Empty, _
Optional ByVal SearchString As String = Empty, _
Optional ByVal PartialResult As Boolean = False)
Dim c As New clsSearchAppointments, i As Integer
c.AppointmentsCount = AppointmentsCount
c.SearchDate = SearchDate
c.Therapist = Therapist
c.SearchFreeAppointments = SearchFreeAppointments
c.SearchString = SearchString
c.PartialResult = PartialResult
InitializeLstResponse
For i = Month(c.SearchDate) To 12
c.Month = i
SearchFreeAppointments_Day c
If Me.lstResponse.ListCount = c.AppointmentsCount Then Exit For
Next
Set c = Nothing
End Sub
Private Sub SearchFreeAppointments_Day(c As clsSearchAppointments)
Dim i As Integer
Set c.Sh = Sheets(Format(DateSerial(1, c.Month, 1), "MMMM"))
c.DayOffset = 1
If c.Month = Month(c.SearchDate) Then c.DayOffset = Day(c.SearchDate)
For i = c.DayOffset To Day(DateSerial(1, c.Month + 1, 0))
c.Day = i
SearchFreeAppointments_Time c
If Me.lstResponse.ListCount = c.AppointmentsCount Then Exit For
Next
End Sub
Private Sub SearchFreeAppointments_Time(c As clsSearchAppointments)
Dim i As Long
If Weekday(DateSerial(Year(c.SearchDate), c.Month, c.Day)) <> 1 Then 'keine Sonntage
c.RowOffset = 10 'suchen ab Zeile
'wenn das Suchdatum = Heute ist, dann erst ab der aktullen Uhrzeit suchen:
If DateSerial(Year(c.SearchDate), c.Month, c.Day) = DateSerial(Year(Date), Month(Date), Day(Date)) Then c.RowOffset = getTimeRow
For i = c.RowOffset To 92 Step 2
c.Row = i
SearchFreeAppointments_Therapist c
If Me.lstResponse.ListCount = c.AppointmentsCount Then Exit For
Next
End If
End Sub
Private Sub SearchFreeAppointments_Therapist(c As clsSearchAppointments)
Dim i As Long
For i = (c.Day - 1) * 6 + 3 To c.Day * 6 + 2
c.Col = i
SearchFreeAppointments_CheckEntry c
If Me.lstResponse.ListCount = c.AppointmentsCount Then Exit For
Next
End Sub
Private Sub SearchFreeAppointments_CheckEntry(c As clsSearchAppointments)
Dim b As Boolean
If c.SearchFreeAppointments Then
b = TherapistIsOk(c) And isClear(c)
Else
b = CheckAppointment(c)
End If
If b Then lstResponseAddItem c
End Sub
Private Sub lstResponseAddItem(c As clsSearchAppointments)
With lstResponse
.AddItem c.Sh.Cells(c.Row, c.Col).Address(0, 0)
.List(.ListCount - 1, 1) = "Frei" 'Frei
If Not c.SearchFreeAppointments Then .List(.ListCount - 1, 1) = c.Sh.Cells(c.Row, c.Col).Text 'Name
.List(.ListCount - 1, 2) = Format(TimeSerial(c.Sh.Cells(c.Row, 1), c.Sh.Cells(c.Row, 2), 0), "HH:mm") 'Zeit
.List(.ListCount - 1, 3) = c.Sh.Cells(8, c.Col).Text & c.Absence 'Therapeut
.List(.ListCount - 1, 4) = c.Sh.Cells(c.Row - 1, c.Col).Text 'Behandlung
.List(.ListCount - 1, 5) = WeekdayName(Weekday(c.Sh.Cells(4, c.Col), vbMonday), , vbMonday) 'Wochentag
.List(.ListCount - 1, 6) = Format(c.Sh.Cells(4, c.Col), "DD.MMM") 'Datum
End With
End Sub
Private Function getTimeRow() As Integer
Dim i As Integer
getTimeRow = 10
i = (Now - Date) * 1440
If i > 420 Then getTimeRow = ((Fix(i / 60) - 6) * 6 + 4) + (Fix((i Mod 60) / 20) + 1) * 2
End Function
Private Function TherapistIsOk(ByVal c As clsSearchAppointments) As Boolean
Dim b As Boolean
b = c.Sh.Cells(8, c.Col) <> Empty
If b And c.Therapist <> Empty Then
b = UCase(c.Sh.Cells(8, c.Col)) = UCase(c.Therapist)
End If
TherapistIsOk = b
End Function
Private Function isClear(ByVal c As clsSearchAppointments) As Boolean
Dim b As Boolean
b = c.Sh.Cells(7, c.Col).Value = Empty
If Not b And UCase(c.Sh.Cells(7, c.Col).Value) = UCase("Teilzeit") Then
b = c.Sh.Cells(c.Row, c.Col).Row < 51
End If
If b Then b = c.Sh.Cells(c.Row, c.Col).Value = Empty
If b Then b = c.Sh.Cells(c.Row, c.Col).Interior.ColorIndex = xlColorIndexNone Or _
c.Sh.Cells(c.Row, c.Col).Interior.ColorIndex = xlColorIndexAutomatic
isClear = b
End Function
Private Function CheckAppointment(ByVal c As clsSearchAppointments) As Boolean
Dim b As Boolean
c.Absence = Empty
If Not c.PartialResult Then
b = UCase(c.Sh.Cells(c.Row, c.Col).Value) = UCase(c.SearchString)
Else
b = CBool(InStr(1, UCase(c.Sh.Cells(c.Row, c.Col).Value), UCase(c.SearchString), vbTextCompare) > 0)
End If
If b And UCase(c.Sh.Cells(7, c.Col).Value) = UCase("Teilzeit") Then
If c.Sh.Cells(c.Row, c.Col).Row > 50 Then
c.Absence = " (Teilzeit)"
End If
Else
If b And Not c.Sh.Cells(7, c.Col).Value = Empty Then
c.Absence = " (" & c.Sh.Cells(7, c.Col).Value & ")"
End If
End If
CheckAppointment = b
End Function
Private Sub cmdPrint_Click()
Dim zeLB As Long, spLB As Long
Dim zeTB As Long, spTB As Long
Dim allesDrucken As Boolean
' Zellen leeren
Range("Druckvorlage!A2:P1000") = ""
' Querformat festlegen
Worksheets("Druckvorlage").PageSetup.Orientation = xlLandscape
'--- Drucker auswählen
Application.Dialogs(xlDialogPrinterSetup).Show
'-- Prüfen, ob alles gedruckt werden muss
For zeLB = 0 To lstResponse.ListCount - 1
allesDrucken = allesDrucken Or lstResponse.Selected(zeLB)
Next
zeTB = 1
'--- selektierte Listboxeinträge in Zellen schreiben
For zeLB = 0 To lstResponse.ListCount - 1
If lstResponse.Selected(zeLB) Or Not allesDrucken Then
zeTB = zeTB + 1
For spLB = 1 To lstResponse.ColumnCount - 1
Sheets("Druckvorlage").Cells(zeTB, spLB + 1) = lstResponse.List(zeLB, spLB)
Next
End If
Next
ThisWorkbook.Unprotect Password:="olli3301"
Sheets("Druckvorlage").Visible = True
' Drucke Tabellenblatt
Worksheets("Druckvorlage").PrintOut
Sheets("Druckvorlage").Visible = False
ThisWorkbook.Protect Password:="olli3301"
End Sub
Private Sub lstResponse_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim s As String
If lstResponse.ListIndex > -1 Then
s = Me.lstResponse.Column(6, Me.lstResponse.ListIndex) & "." & Sheets("Januar").Range("A1")
Sheets(Format(s, "MMMM")).Select
If lstResponse.Tag <> "" Then
Range(lstResponse.Tag).Interior.ColorIndex = 0
Cells(8, Range(lstResponse.Tag).Column).Interior.ColorIndex = 0
Cells(Range(lstResponse.Tag).Row, 1).Interior.ColorIndex = 43
Cells(Range(lstResponse.Tag).Row, 2).Interior.ColorIndex = 19
End If
Range(lstResponse.Value).Select
ActiveCell.Interior.ColorIndex = 4
Cells(8, ActiveCell.Column).Interior.ColorIndex = 4
Cells(ActiveCell.Row, 1).Interior.ColorIndex = 4
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 4
lstResponse.Tag = ActiveCell.Address
Cancel = True
End If
'Form schließen:
Unload Me
End Sub