Bepaalde criteria zoeken en op apart tabblad onder elkaar zetten

[samui]

Beste helpers,

Ik wil graag de "di" en "hi" dames en heren in kolom D uitgefilterd en onder elkaar gezet in een apart tabblad Dag (beginnend vanaf Cel Y20) weggezet krijgen.
Daarnaast zie ik dit graag elke dag apart gebeuren. Enkel die personen moeten in beeld komen die voldoen aan de d die staat onder de kolommen F t/m J van de bewuste dag ( zie tabblad Deze week )
Zoals je ziet zouden er 7 . 7 , 3 , 5 , 4 di dames moeten zijn met een d in week 48 van maan- t/m vrijdag
Zoals je ziet zouden er 7 , 7 , 5 , 6 , 6 hi heren moeten zijn met een d in week 48 van maan- t/m vrijdag

Deze zou ik dus enkel met voornaam en di of hi dmv een macro onder elkaar weggezet zien in tabblad DAG beginnen in cel Y20 zie voorbeeld.
Op maandag zou ik dus de rij ingevuld zien verschijnen zoals het voorbeeld laat zien in tabblad Dag
De woensdag zou er in die week uit moeten zien zoals in kolom AD en AE te zien is. Echter alle dagen zouden moeten beginnen in cel Y20

Als bovenstaande wat te complex is zou ik ook al heel blij zij als de bewuste di en hi die voldoen aan het criterium d in kolommen F t/m J) allemaal in beeld komen met alle dagen van de week die de d bevatten.
Voorbeeld uitgesplitst te zien in kolom AN20 en verder

Hopelijk heb ik het goed uitgelegd en komt iemand met een mooi oplossinkje voor me.

 

[HSV]

In de code staat (date+4).
Die +4 staat er om het te testen (nadien weghalen).
Test het ook eens met 2,3 enz.
Vandaag is het 21-11-2015 dus +4 = 25-11-2015.

Sub hsv()
Dim c As Range, tb As Range, i As Long
Application.ScreenUpdating = False
With Sheets("Deze week")
Set c = .Range("F3:K3").Find(Date + 2, , xlFormulas, xlWhole)
If Not c Is Nothing Then
 Sheets("dag").Range("Y20").CurrentRegion.Clear
     For i = 1 To 2
      .UsedRange.Offset(3).AutoFilter c.Column, "d"
      .UsedRange.Offset(3).AutoFilter 4, IIf(i = 1, "di", "hi")
      
        Set tb = .AutoFilter.Range.Offset(1).Columns(2).SpecialCells(12).SpecialCells(2)
        Set tb = Union(tb, .AutoFilter.Range.Offset(1).Columns(4).SpecialCells(12).SpecialCells(2))
        tb.Copy Sheets("dag").Range(IIf(i = 1, "Y20", Sheets("dag").Cells(Rows.Count, 25).End(xlUp).Offset(1).Address))
      .UsedRange.Offset(3).AutoFilter
     Next i
 End If
 End With
End Sub

 

[samui]

Super de luxe

Harry, perfect. Precies wat ik bedoel.
Nog 1 dingetje extra misschien.
Zou de bewuste dag M,D,W,D,V nog boven de 1e di op tabblad Dag geplaatst kunnen worden?

 

[HSV]

Mooi, dit stukje even aanpassen tussen de hoofdlijnen.

If Not c Is Nothing Then
 With Sheets("dag")
   .Range("Y20").CurrentRegion.Clear
   .Range("Z19") = Date
 End With
     For i = 1 To 2

 

[samui]

Dank je wel

Harry,

Bedankt weer ik ben er heel blij mee.
Werkt perfect.
Enkel als 1 van de 2 de di of de hi , of beiden, op nul staat blijft de filter in staan en krijg ik een foutmelding
Als ik een nul zie weet ik dat ik geen macro kan testen.......
Of is het een snelle handeling van jouw kant, als 1 van de 2 een nul (0) als waarde heeft zodat er dan niks weggezet wordt en de namen blijven in beeld in het tabblad Deze week?
Zie bijalge

Anders houdt ik het zo en kan ik er mee leven en werken.

mvg,

Frank

 

[HSV]

Ik denk hiermee alle fouten te hebben uitgesloten Frank.
Test alle denkbare scenario's eens.

 

[samui]

Thanks

Beste Harry,

Ik kan mijn vraag weer sluiten.
Hij is helemaal goed zo. Superbedankt Harry.
We zijn blij met jullie.
Tot een volgende keer weer.
Ik sluit mijn topic.

Frank :thumb:



Ik had mijn error hier ingebouwd.
Dit was voldoende voor de weekeinds.
Hij stond dus op de verkeerde plek en met de verkeerde tekst.

On Error GoTo err1
.UsedRange.Offset(3).AutoFilter c.Column, "d"
.UsedRange.Offset(3).AutoFilter 4, IIf(i = 1, "di", "hi")

Set tb = .AutoFilter.Range.Offset(1).Columns(2).SpecialCells(12).SpecialCells(2)
Set tb = Union(tb, .AutoFilter.Range.Offset(1).Columns(4).SpecialCells(12).SpecialCells(2))

tb.Copy Sheets("dag").Range(IIf(i = 1, "Y20", Sheets("dag").Cells(Rows.Count, 25).End(xlUp).Offset(1).Address))
.UsedRange.Offset(3).AutoFilter
err1:
Next i