Moin,
nee, Danke.
Von dem Code kann man außer den drei Zeilen mit der Listbox nichts weiter nutzen.
Du willst ja nicht alle leeren Zellen in der Ausgabe haben. Eben auch solche nicht, wenn oben kein Name steht.
Des weiteren ist Dein UsedRange riesig, der würde auch mit angepackt werden.
Die Datei ist etwas ..., naja, ... 'gewohnungsbedürftig'. Eigentlich benötigt die Datei dringend heilende Hände.
Trotz allem, einen Versuch habe ich mal als Entwurf schnell zusammen gestrickt.
Frech wie ich bin, habe ich Deine tausend Hilfszellen einfach mit genutzt.
Da es beim Auslesen einer bedingten Formatierung manchmal Probleme geben kann, fragt der Code einfach die Abwesenheitszelle ab.
Wenn dort 'Teilzeit' drin steht, dann werden nur Zeiten bis 13:40 Uhr berücksichtigt. Wenn Du also bei der bedingten Formatierung etwas ändern solltest, dann muss das in der Funktion 'isClear' angepasst werden.
Ansonsten läuft das Dingens und listet die freien Termin ab dem Suchzeitpunkt auf.
Habe für den Test Dein Userform2 missbraucht.
Hinweis:
Der Code geht davon aus, dass alle Monats-Sheets vorhanden sind.
Zum Aufruf:
Es kann optional die gewünschte max. Anzahl der Einträge und ebenso ein Wunschtherapeut an diese Suchfunktion übergeben werden
Code:
Private Sub CommandButton1_Click()
SearchForFreeAppointment 200, TextBox1.Text
End Sub
Private Sub SearchForFreeAppointment(Optional ByVal AppointmentsCount As Integer = 100, Optional ByVal therapist As String = Empty)
Dim sh As Worksheet, iMonth As Integer, iDay As Integer
Dim iDayOffset As Integer, iRowOffset As Integer, iRow As Integer, iCol As Integer
ListBox1.Clear
ListBox1.ColumnWidths = "0cm;6cm;1cm;1cm;3cm;3cm;3cm;3cm" ' Breite der Spalte
For iMonth = Month(Date) To 12
Set sh = Sheets(Format(DateSerial(1, iMonth, 1), "MMMM"))
iDayOffset = 1
If iMonth = Month(Date) Then iDayOffset = Day(Date)
For iDay = iDayOffset To Day(DateSerial(1, iMonth + 1, 0))
iRowOffset = 10
If DateSerial(Year(Date), iMonth, iDay) = DateSerial(Year(Date), Month(Date), Day(Date)) Then iRowOffset = getTimeRow
For iRow = iRowOffset To 92 Step 2
For iCol = (iDay - 1) * 6 + 3 To iDay * 6 + 2
If isTherapistOk(sh.Cells(8, iCol), therapist) And isClear(sh.Cells(iRow, iCol), sh.Cells(7, iCol)) Then
With ListBox1
.AddItem sh.Cells(iRow, iCol).Address(0, 0)
.List(.ListCount - 1, 1) = "Frei" 'Name
.List(.ListCount - 1, 2) = Cells(iRow, 1).Text 'Stunde
.List(.ListCount - 1, 3) = Cells(iRow, 2).Text 'Minute
.List(.ListCount - 1, 4) = Cells(8, iCol).Text 'Therapeut
.List(.ListCount - 1, 5) = Cells(iRow - 1, iCol).Text 'Behandlung
.List(.ListCount - 1, 6) = Cells(2, iCol).Text 'Tag
.List(.ListCount - 1, 7) = Cells(4, iCol).Text 'Tag
If .ListCount = AppointmentsCount Then Exit Sub
End With
End If
Next iCol
Next iRow
Next iDay
Next iMonth
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 isTherapistOk(ByVal rngTherapist As Range, ByVal therapist As String) As Boolean
Dim b As Boolean
b = rngTherapist.Value <> Empty
If b And therapist <> Empty Then
b = UCase(rngTherapist) = UCase(therapist)
End If
isTherapistOk = b
End Function
Private Function isClear(ByVal rngTime As Range, ByVal rngAbsence As Range) As Boolean
Dim b As Boolean
b = rngAbsence.Value = Empty
If Not b And UCase(rngAbsence.Value) = UCase("Teilzeit") Then
b = rngTime.Row < 51
End If
If b Then b = rngTime.Value = Empty
If b Then b = rngTime.Interior.ColorIndex = xlColorIndexNone Or _
rngTime.Interior.ColorIndex = xlColorIndexAutomatic
isClear = b
End Function
Das geht sicherlich noch besser, für den Anfang sollte es aber reichen.
Gruß Carsten