Hoe nu een willekeurige dag te kiezen en namen die hierbij horen in beeld te krijgen

[samui]

Ik heb hier van Harry laatst een mooie macro gekregen om de di en hi personen in beeld te krijgen.
Onderstaande code is om vandaag de namen in beeld te krijgen - 4 dagen ivm komende weekeind. ( ivm zaterdag geen namen in beeld )

Mijn vraag is: Hoe krijg ik nou de rijen, Y7 t/m Z40, in beeld per dag die ik kies? Ik wil namelijk bijvoorbeeld op maandag graag weten wie ik vrijdag aanwezig heb.
Ik heb in de cellen T1 t/m X1 al blokjes staan die die dag in beeld moeten laten zien dmv de macro.
Klik ik op de Di wil ik altijd de dinsdag van de 1e week in het tabblad Deze week, de namen ingevuld zien vanaf Y6 t/m Z40 in het tabblad dag
Klik ik op Do zou ik graag altijd de donderdag van de 1e week in het tabblad Deze week, de namen ingevuld zien vanaf Y6 t/m Z40 in het tabblad dag
Ik heb al wat zitten vogelen met vbThursday op de plek van find(date +1) maar daar had hij geen zin in.

Hoop dat jullie weer een oplossing hebben?
Alvast bedankt voor jullie reacties :thumb: :thumb:

Frank

Sub DiHiDAG()
Application.ScreenUpdating = False
Sheets("Deze week").Unprotect
Dim C As Range, tb As Range, i As Long
With Sheets("Deze week")
Range("Y2:Z40").Select
Selection.ClearContents
With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
Set C = .Range("F3:K3").Find(Date - 4, , xlFormulas, xlWhole)
If Not C Is Nothing Then
 With Sheets("dag")
   .Range("Z4") = "di & hi"
   .Range("Z5") = "voor"
   .Range("Z6") = Date - 4
 End With
    Range("Z6").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 6737151
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.NumberFormat = "dddd"
    Selection.Font.Bold = False
    Columns("Z:Z").EntireColumn.AutoFit
      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))
   On Error Resume Next
        tb.Copy Sheets("dag").Range(IIf(i = 1, "Y7", IIf(Sheets("dag").Range("y7") = "", "y7", Sheets("dag").Cells(Rows.Count, 25).End(xlUp).Offset(1).Address)))
    On Error GoTo 0
      .UsedRange.Offset(3).AutoFilter
     Next i
 End If
 End With
 Sheets("Deze week").Protect
Sheets("Dag").Select
  Range("Y2:Z40").Select
    With Selection.Font
        .Name = "MS Sans Serif"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Bold = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Selection.Font.Italic = False
  Range("Z2:Z28").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
Range("S2").Select
End Sub

 

[HSV]

Het is wel een gedeeltelijke code van mij (ik gebruik bijna nooit select en selection).

Test dit maar eens weer.

Option ExplicitSub DiHiDAG()
Application.ScreenUpdating = False
Dim tb As Range, kolom As Long, i As Long
With Sheets("Deze week")
 .Unprotect
    kolom = Application.Match(ActiveSheet.Shapes(Application.Caller).TextEffect.Text, Application.Text(.Range("E3:K3"), "[$-413]ddd"), 0)
       If Not IsError(kolom) Then
 With Sheets("dag")
    With .Range("Y2:Z40")
     .Clear
     .Font.Name = "MS Sans Serif"
     .Font.Size = 10
    End With
      .Range("Z4") = "di & hi"
      .Range("Z5") = "voor"
      .Range("Z6") = StrConv(Format(Sheets("deze week").Cells(3, kolom + 4), "dddd"), vbProperCase)
      .Range("Z6").Interior.Color = 6737151
      .Columns(26).AutoFit
 End With
      For i = 1 To 2
        .UsedRange.Offset(3).AutoFilter kolom + 4, "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))
   On Error Resume Next
        tb.Copy Sheets("dag").Range(IIf(i = 1, "Y7", IIf(Sheets("dag").Range("y7") = "", "y7", Sheets("dag").Cells(Rows.Count, 25).End(xlUp).Offset(1).Address)))
    On Error GoTo 0
      .UsedRange.Offset(3).AutoFilter
     Next i
   End If
   .Protect
 End With
End Sub

 

[samui]

Beste Harry,

Gewoonweg subliem weer. Ik weet dat het een gedeelte van jouw macro was. Ik verknal de beauty ervan nog met select en selection
Kan topic alweer sluiten. Grote lof wederom. Geef je geen cursussen?

groet en thanks,

Frank