Duplicaten zoeken in rode font in zelfde range over drie laatste worksheets

[Sp0ns]

Besten,

Ik ben werkzaam in een psychiatrisch ziekenhuis waar we werken met excel-lijsten waarmee de therapie-aanwezigheid van patiënten gecontroleerd wordt.
Patiëntennamen worden ingevuld in de lijsten en we hebben nood aan een eenvoudig systeem (lang leve VBA) om te controleren of een patiënt drie weken achtereen niet voor zijn sessie is komen opdagen. Ik ken wel wat basis van VBA maar er zijn teveel factoren om te integreren, geraak er niet aan uit.

- De drie laatste worksheets (meest rechtse in chronologie) van het document zijn het zoekgebied (elke week wordt een nieuw tabblad gemaakt maar de vraag is of patiënt de laatste drie weken afwezig is geweest in zijn sessie)
- In deze worksheets worden duplicaten gezocht van patiëntnamen
- Deze duplicaten mogen enkel weergegeven worden indien de naam van patiënt drie maal in rode font (=afwezig) heeft gestaan (duplicaten komen veelvuldig in het zwart voor maar enkel driemaal rode achtereen zijn belangrijk om te weten)
- Deze duplicaten mogen enkel weergegeven worden indien het gaat over drie maal een duplicaat in dezelfde range. Dit is misschien nog het meest complexe dus wat extra uitleg. Patiëntennamen komen binnen een worksheet op meerdere plaatsen voor gezien ze verschillende sessies volgen. Een exceldocument heet bv. "fitness" maar bevat meerdere vakken in verscheidene kolommen en rijen. De vraag is of hij voor 1 specifieke sessie driemaal niet aanwezig is geweest. Het handige is wel dat de tabbladen steeds gekopieerd worden naar een volgende week, dus als patiënt deze week in "D14" geregistreerd staat voor zijn sessie zal dat voor volgende week (=volgend worksheet) ook zo zijn.
- Weergave duplicaten mag Interior.color = vbYellow of zoiets zijn. Op termijn lijkt me een msgbox handig waarin de namen van patiënten weergegeven worden maar ik wil eerst de basis ontwerpen

Een vette kluif en besef ik maar al te goed, alle hulp is meer dan welkom. Indien er tips zijn om de basisregistratie te versimpelen zijn ze ook welkom.
Indien iets onduidelijk of onmogelijk is, laat me graag iets weten.

Met vriendelijke groet en dank bij voorbaat :thumb:,

Maarten

 

[HSV]

Hallo Maarten,

Ik weet niet als ik het bestand zie of ik er wat van kan of wil maken, maar het bestand plaatsen zonder gevoelige info kan altijd.
Soms ontgaat je de zin als je een bestand ziet.

 

[Sp0ns]

Hoi HSV,

Alvast bedankt voor je antwoord
Heb even nagekeken en in theorie staan overal enkel voornamen met eerste letter van achternaam en geen persoonsgegegevens (adres, geboortedatum, ...) dus in principe mag ik het deontologisch gezien wel delen

Misschien nog even melden dat als het te complex is om op alles een antwoord te geven dat een deel van het antwoord ook al zeer welkom is (bv. hoe zoek ik in de laatste drie worksheets, hoe zoek ik items die in zelfde celrange staan, ...)

 

[HSV]

Hoi Maarten,

Test de code maar eens.
Ik heb de namen "Peter VR. (for.3) & Giovanni N (FOR1)" even van een rode fontkleur voorzien in de laatste drie bladen voor de test.


edit: zoekrange is in dit bestand per kolom.
Als dit aangepast moet worden (bv.cel op cel) verneem ik het wel.

 

[Sp0ns]

HSV,

Alvast enorm bedankt voor je code ! Dit hadden we nooit zelf uit kunnen werken :thumb:

Enkele vraagjes nog:

- Stel dat we nu willen kijken over de laatste vier worksheets, is dit dan gewoon Set sh = Sheets(Sheets.Count -3) ? Of veranderen er nog zaken in de formule ?

- Is het inderdaad ook mogelijk om cel op cel te vergelijken ?

Nogmaals hartelijk dank voor je werk !

Groeten, Maarten


Sub hsv()
Dim sn, sh As Worksheet, j As Long, i As Long, c As Range, x As Long, xx As Long

With CreateObject("scripting.dictionary")
Set sh = Sheets(Sheets.Count - 2)
For j = 2 To sh.UsedRange.Columns.Count
For i = 3 To sh.UsedRange.Rows.Count
If sh.Cells(i, j).Font.ColorIndex = 3 Then
For x = Sheets.Count - 1 To Sheets.Count
Set c = Sheets(x).Columns(j).Find(sh.Cells(i, j), , xlValues, xlWhole)
If Not c Is Nothing Then
If c.Font.ColorIndex = 3 Then xx = xx + 1
If xx = 2 Then
.Item(sh.Cells(i, j).Value) = .Item(sh.Cells(i, j).Value)
End If
End If
Next x
End If
xx = 0
Next i
Next j
MsgBox Join(.keys, vbLf)
End With
End Sub

 

[snb]

Gebruik svp code tags rondom VBA-code

Wees slim en beperk je tot 2 werkbladen.

Werkblad 1: alle persoonsnamen in kolom A
alle afdelingsgegevens van iedere persoon in kolom B
sessie in kolom C
datum en tijdstip van de sessie in kolom D
afwezigheid in kolom E
voor iedere sessie opnieuw de gegevens van de persoon opvoeren

maak van de tabel een slimme Exceltabel

Werkblad 2: een weekoverzicht waarin de gegevens uit werkblad 1 voor die week als weekplanning staan gegroepeerd (zoals je nu per week hebt)
per pesoon een kolom voor afdelingsgegevens
per persoon een afwezigheidskolom
validatie in de cellen met alle persoonsnamen

In werkblad 1 kun je dan eenvoudig filteren en daarmee je vraag beantwoorden over de aan/afwezigheid.

 

[HSV]

Misschien is het een overweging waard te implementeren wat @snb voorstelt.
Zo niet dan is hier alvast de code voor de vraag.

Vier bladzijden; cel op cel controle.

Sub hsv()
Dim sn, sh As Worksheet, j As Long, i As Long, c As Range, x As Long, xx As Long
With CreateObject("scripting.dictionary")
Set sh = Sheets(Sheets.Count - 3)
  For j = 2 To sh.UsedRange.Columns.Count
   For i = 3 To sh.UsedRange.Rows.Count
    If sh.Cells(i, j).Font.Color = vbRed Then
        For x = Sheets.Count - 2 To Sheets.Count
          If Sheets(x).Cells(i, j) = sh.Cells(i, j) And Sheets(x).Cells(i, j).Font.Color = vbRed Then xx = xx + 1
          If xx = 3 Then .Item(sh.Cells(i, j).Value) = .Item(sh.Cells(i, j).Value)
        Next x
       End If
      xx = 0
    Next i
   Next j
   MsgBox Join(.keys, vbLf)
 End With
End Sub

 

[Sp0ns]

@HSV, wederom hartelijk dank voor de aanvulling.
Heb het programma ook even voorgesteld aan de collega's en we zijn je gezamenlijk zeer dankbaar. Merci voor de moeite :thumb:

@snb, heb je gelijk in hoor. Het is zeker niet het meeste slimme document wat werd opgesteld. Ik ben ook van plan om hun documenten te gaan herwerken maar het gaat hier over een 20-tal sessies over meerdere uren over meerdere dagen voor meer dan 600 patiënten... Daarom dat ik graag even een formule wou vragen om mijn collega's (tijdelijk) voort te helpen zodat ik op lange termijn de documenten kan herwerken. Alvast bedankt voor je tips !

Met vriendelijke en dankbare groeten,

Maarten

 

[puppie]

op verzoek is dit topic heropend.

en op verzoek ook weer gesloten.