Suchen und auflisten

[DbSam]

Hallo Arni,

bin gestern Abend nicht mehr dazu gekommen.
Daher jetzt die Anpassungen ...

• Bitte lege Dir eine Sicherungskopie Deiner originalen Datei an
  
• im VBA-Projekt Dein UserForm21 entfernen
  
• dann bitte die Klasse und das neue Userform21 importieren
  
• testen
  

Deinen Code habe ich weitestgehend so drin gelassen, nur etwas glatt gezogen.
Beide Suchen durchlaufen die gleichen Subs, nur bei der Zellenauswahl wird mal kurz ausgeschert.

Solche Monats-Sheet-Geschichten sind immer eine Krücke und entsprechen schon per Definition einem fehlerhaftes Design.
Hast Du sicher schon gemerkt. Also entweder umbauen oder Du musst den Heldentod sterben. :D


Gruß Carsten


Ach, die Tante Edith hat noch was vergessen:
Das Form wird jetzt immer geschlossen und nicht mehr nur versteckt.
Daher wird die Initialisierungsroutine nun immer durchlaufen und die Kundennamen sind also beim Start immer aktuell.
Den Schließen-Button habe ich auch ausgebaut. Das Form wird per Doppelklick auf den Listeneintrag oder über das normale Schließkreuzel geschlossen. Die Routinen habe ich an die richtigen Stellen verschoben, Du musst die Anwender nicht mehr so gängeln.

[Arni49]

Hallo Carsten,

bin begeistert wie Du es umgesetzt hast .

Melde mich die Tage nochmal wenn ich alles getestet habe.

Gruß Arni

[DbSam]

Hallo Arni,

langsam. :)

Das ist nur ein erster Entwurf, eine halbwegs funktionierende Vorlage, ein Rumpf - mehr nicht.
Dieser benötigt Deinerseits noch einige Überlegungen und Verbesserungen.
Die Suche funktioniert natürlich für den Anfang so, man kann aber noch mehr daraus machen.


Gruß Carsten

[Arni49]

Hallo Carsten,

bin schon voller Erwartung was Dir noch so einfällt :)

Jetzt mach ich aber erstmal schluss, Morgen muss ich wieder Früh raus.

Danke

Gruß Arnold

[Arni49]

Hallo Carsten,

hattest Du nochmal Zeit drüber zu schauen ?
Die Suche findet leider keine Einträge an dem aktuellem Tag.

Grüße Arnold

[schauan]

Hallöchen,

kannst Du eventuell noch mal Deinen Stand mit den Änderungen posten? Meinst Du mit dem aktuellen Tag den jeweils heutigen?

[Arni49]

Hallo,

hier mein derzeitiger Stand und ja die Suche findet nichts am heutigen Tag.

Klassenmodul

Code:

Option Explicit

Private mSh As Worksheet
Private mMonth As Integer
Private mRowOffset As Integer
Private mDay As Integer
Private mDayOffset As Integer
Private mRow As Long
Private mCol As Long
Private mAppointmentsCount As Long
Private mSearchDate As Date
Private mTherapist As String
Private mMonat As String
Private mSearchString As String
Private mAbsence As String
Private mSearchFreeAppointments As Boolean
Private mPartialResult As Boolean

Public Property Get Sh() As Worksheet
   'If mSh Is Nothing Then Set Sh = New Worksheet
   Set Sh = mSh
End Property
Public Property Set Sh(ByVal Value As Worksheet)
   Set mSh = Value
End Property

Public Property Get Month() As Integer
   Month = mMonth
End Property
Public Property Let Month(ByVal Value As Integer)
   mMonth = Value
End Property

Public Property Get RowOffset() As Integer
   RowOffset = mRowOffset
End Property
Public Property Let RowOffset(ByVal Value As Integer)
   mRowOffset = Value
End Property

Public Property Get Day() As Integer
   Day = mDay
End Property
Public Property Let Day(ByVal Value As Integer)
   mDay = Value
End Property

Public Property Get DayOffset() As Integer
   DayOffset = mDayOffset
End Property
Public Property Let DayOffset(ByVal Value As Integer)
   mDayOffset = Value
End Property

Public Property Get Row() As Long
   Row = mRow
End Property
Public Property Let Row(ByVal Value As Long)
   mRow = Value
End Property

Public Property Get Col() As Long
   Col = mCol
End Property
Public Property Let Col(ByVal Value As Long)
   mCol = Value
End Property

Public Property Get AppointmentsCount() As Long
   AppointmentsCount = mAppointmentsCount
End Property
Public Property Let AppointmentsCount(ByVal Value As Long)
   mAppointmentsCount = Value
End Property

Public Property Get SearchDate() As Date
   SearchDate = mSearchDate
End Property
Public Property Let SearchDate(ByVal Value As Date)
   mSearchDate = Value
End Property

Public Property Get Therapist() As String
   Therapist = mTherapist
End Property
Public Property Let Monat(ByVal Value As String)
   mMonat = Value
End Property
Public Property Get Monat() As String
   Monat = mMonat
End Property
Public Property Let Therapist(ByVal Value As String)
   mTherapist = Value
End Property
Public Property Get SearchString() As String
   SearchString = mSearchString
End Property
Public Property Let SearchString(ByVal Value As String)
   mSearchString = Value
End Property

Public Property Get Absence() As String
   Absence = mAbsence
End Property
Public Property Let Absence(ByVal Value As String)
   mAbsence = Value
End Property

Public Property Get SearchFreeAppointments() As Boolean
   SearchFreeAppointments = mSearchFreeAppointments
End Property
Public Property Let SearchFreeAppointments(ByVal Value As Boolean)
   mSearchFreeAppointments = Value
End Property

Public Property Get PartialResult() As Boolean
   PartialResult = mPartialResult
End Property
Public Property Let PartialResult(ByVal Value As Boolean)
   mPartialResult = Value
End Property

Userform

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
 


 

[schauan]

Hallöchen,

ich hätte nun eine Datei mit anonymisierten Daten gehofft. Habe den Code jetzt noch nicht analysiert.
Passen denn die Codes zu Deiner ersten Datei, gehört der Userformcode in Dein Userform2 oder muss da noch das von DbSam rein, wie heißt das Klassenmodul (habe im Code nach cls gesucht -meistens fangen die damit an - und nix gefunden), ...