21.02.2018, 06:46 (Dieser Beitrag wurde zuletzt bearbeitet: 21.02.2018, 06:46 von 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.
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.
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
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
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
'-- 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)
' 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
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), ...
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
Habe den Code jetzt noch nicht analysiert.