Suchen und auflisten

[Arni49]

---

Hallo,


ich suche einen Code mit dem ich mir nur die Leeren und nicht Farblich gekennzeichneten  Zeilen in meiner Tabelle suchen und auflisten kann.
Die zu findenen Zellen sind immer jeweils durch eine zelle getennt, sprich nur jede zweite.

Wäre Super wenn jemand vorschläge hätte.

habe die Arbeitsmappe mal Reduziert angehangen.

Danke

[DbSam]

gelöscht ...

[Arni49]

Hallo DbSam,


Wollte das ganze in eine Userform packen und brauche deshalb einen VBA Code.
was mach ich mit den Zellen die nicht durchsucht werden sollen weil Sie eingefärbt sind ??

Habe dei Datei mal zum besserem Verständnis angehangen.

Gruß

[DbSam]

Hallo Arni,

sorry, hatte Deine Datei dann erst entdeckt. Da geht mein Vorschlag natürlich nicht.
Wollte meinen Beitrag noch schnell löschen bevor Du ihn entdeckst, ich war aber zu langsam.


Gruß Carsten


Edit:
Was hast Du vor?
Willst Du freie Termine suchen?
Nur im aktuellen Monat, oder den nächsten freien bei irgendeinem Therapeuten, oder den nächsten freien bei Anke oder Oliver?
Im Moment bin ich auf Grund der Unübersichtlichkeit etwas erschlagen und habe keine gescheite Idee.

Eine Kurzform vom Code ist auch nicht so einfach möglich, da Deine Tabellen keine als 'intelligent' formatierte Tabellen sind und die UsedRange jeweils unerhört groß ist.
Man muss also den Code sehr speziell anpassen.

Vielleicht gibst Du noch ein paar Details Deiner Vorstellung preis.

[Arni49]

Hallo,

das ist der Code für die Suche nach befüllten Zellen, vielleicht kann mann da ja auch die Suche nach Leeren Zellen einbauen.

Code:

Private Sub OptionButton1_Click()
 'Monate
 Dim iCnt%
 Me.ComboBox1.Clear
 For iCnt = 1 To 12
   Me.ComboBox1.AddItem Format(DateSerial(1, iCnt, 1), "mmmm")
 Next
End Sub

Private Sub CommandButton2_Click()
If ListBox1.Tag <> "" Then
Range(ListBox1.Tag).Interior.ColorIndex = 0
Cells(8, Range(ListBox1.Tag).Column).Interior.ColorIndex = 0
Cells(Range(ListBox1.Tag).Row, 1).Interior.ColorIndex = 43
Cells(Range(ListBox1.Tag).Row, 2).Interior.ColorIndex = 19
End If
UserForm1.Hide
End Sub
Private Sub CommandButton1_Click()
   
   Dim iCnt%
   
 If Len(TextBox1.Text) = 0 Then    'Textbox leer ??
     MsgBox "Suchtext eingeben"
     Exit Sub
  End If
   
   ListBox1.Clear
   ListBox1.ColumnWidths = "0cm;6cm;1cm;1cm;3cm;3cm;3cm;3cm"   ' Breite der Spalte

  If OptionButton3 = True Then
       Me.ComboBox1.Clear
       For iCnt = 1 To 12
                             Sheets(Format(DateSerial(1, iCnt, 1), "mmmm")).Activate
                                FindData
       Next
   Else
   If ComboBox1.Value = "" Then
   MsgBox "Bitte wählen, wo(Monat oder Jahr)der Begriff gesucht werden soll!", vbExclamation, "Achtung!"
   Else
   If ComboBox1.Value <> "" Or OptionButton3 = True Then           'Prüfen ob Monat ausgewält ist
       Sheets(ComboBox1.Value).Activate
       FindData
  End If
End If
End If
End Sub
Private Sub FindData()

   Dim myLookAt As XlLookAt, strFirstAddress As String, rngFound As Range   'Suchart, Erste Adresse als Zeichenfolge, Bereich
   
   myLookAt = IIf(CheckBox1.Value, xlPart, xlWhole)    'Suchart XLPART Teilergebnis, XLWhole Exakte Suche
   With ActiveSheet.UsedRange                          'Benutzer Bereich in der Aktiven Tabelle
     
      Set rngFound = .Find(What:=TextBox1.Text, LookIn:=xlValues, LookAt:=myLookAt, SearchOrder:=xlByColumns)
      If rngFound Is Nothing Then
         MsgBox "Keine Termine vorhanden"
         Exit Sub
      End If
   
      strFirstAddress = rngFound.Address(0, 0)
      Do
        ListBox1.ColumnWidths = "0cm;6cm;1cm;1cm;3cm;3cm;3cm;3cm"   ' Breite der Spalte
        ListBox1.AddItem rngFound.Address(-1, 0)
         ListBox1.AddItem rngFound.Address(0, 0)
           ListBox1.List(ListBox1.ListCount - 1, 1) = rngFound.Text        ' Name
           ListBox1.List(ListBox1.ListCount - 1, 2) = Cells(rngFound.Row, 1).Text      ' Stunde
           ListBox1.List(ListBox1.ListCount - 1, 3) = Cells(rngFound.Row, 2).Text      ' Minute
           ListBox1.List(ListBox1.ListCount - 1, 4) = Cells(8, rngFound.Column).Text   'Therapeut
           ListBox1.List(ListBox1.ListCount - 1, 5) = Cells(rngFound.Row - 1, rngFound.Column).Text 'Behandlung
           ListBox1.List(ListBox1.ListCount - 1, 6) = Cells(2, rngFound.Column).Text  'Tag
           ListBox1.List(ListBox1.ListCount - 1, 7) = Cells(4, rngFound.Column).Text  'Datum
         Set rngFound = .FindNext(rngFound)
      Loop Until rngFound.Address(0, 0) = strFirstAddress
   End With
End Sub

[DbSam]

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

[Arni49]

Hallo Carsten,

sorry das ich so lange nicht draufgeschaut habe.
Danke vorweg für deine Bemühungen.
Es ist nicht zu übersehen das Du mit Excel schon erhäblich weiter bist als ich, denke auch das ich etwas nicht richtig verstanden habe.

Genutzt hast Du die Userform2, dort habe ich den Code hinein kopiert, gebe ich dort einen Therapeut oder nichts ein bekomme ich, wie im Bild zu sehen, diese Anzeige ?


Kannst Du bitte etwas Licht ins Dunkel bringen, Danke

[Arni49]

Sorry, doch klatt das Bild vergessen

[DbSam]

Hallo Arni,

naja, vielleicht hast Du in der Zwischenzeit an Deinem Userform2 Änderungen vorgenommen.
Warte, ich baue mal schnell aus Deinem Userform2 ein Userform 3 ...

Immer in der Hoffnung, dass sich der Aufbau Deiner Monatstabellen nicht geändert hat
(Nur nebenbei: Wobei ich an Deiner Stelle deren Aufbau ganz gewiss ändern und die Zeilen mit den Spalten tauschen würde. Dann könnte man alles untereinander und über den Jahreswechsel hinaus fortschreiben. Und die vielen Hilfsspalten/-zellen könnten auch entfallen. Man könnte auch ...)


Gruß Carsten

[Arni49]

Hallo Carsten,

ein Besch..... Tag
Habe Dir eine EMAIL gesendet, leider ist diese evtl. mehrfach angekommen, Sorry.

Heute eine Update meiner Security Software und jetzt spinnt Outlook völlig.

Gruß Arni