• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Formule bij gebruik tabbladen en gebruik van filter.

Status
Niet open voor verdere reacties.
Sorry, ik heb de vraag weer in de "vraag stand"gezet.

In de geleverde HSV in het bestaand excell bestand komen iedere keer nieuwe tabbladen met de gegevens vanuit het tabblad "ledenljst

Nu is mijn vraag het volgende:Kan ik in de aparte tabbladen o.a. van de maandag kolommen toevoegen waarin de de bovenste regel de datums komen.
Dus op tabblad van Ma. 12, Ma. 13. Ma. 18, Ma. 19, en Ma. 20 moeten de maandagen van september komen t.w. 3 - 10 - 17 - 24.
Voor de dinsdag 09 - 10 enz. natuurlijk de datums in september van dinsdag 4 - 11- 18 - 25 (in aparte kolommen

Is dit mogelijk?

Groeten,

Harry
 
Ik heb dit stuk veranderd.
De resultaten staan in de eerste rij, de laatste 4 of 5 kolommen.
De code zal wel steeds meer tijd in beslag nemen bij wat je vraagt.
Code: 
With ActiveSheet                             'geeft het nieuwe blad de naam, de kopregel en de gegevens.
   .Name = cl
   .Cells(1, 1).Resize(, 20) = Split(Join(Application.Index(Sheets("Ledenlijst TSRM").Cells(1, 2).Resize(, 20).Value, 1, 0), "|"), "|")
    Sheets("Ledenlijst TSRM").AutoFilter.Range.Offset(1, 1).SpecialCells(12).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
     For y = 1 To 30
     Select Case Left(cl, 2)
      Case "MA"
        sq = 1
      Case "DI"
        sq = 2
      Case "WO"
        sq = 3
      Case "DO"
        sq = 4
      Case "VR"
        sq = 5
      Case "ZA"
        sq = 6
    End Select
     c = WorksheetFunction.Choose(sq, 2, 3, 4, 5, 6, 7)
     myday = y & "-9-2012"
        If Weekday(myday) = c Then
       .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = Format(myday, "d")
       End If
      Next y
   
   .Columns.AutoFit
 

Bijlagen

Alles werkt maar alleen de volgorde van de tabbladen niet maar.
Ik bedoel dus eerst alle maandagen met tijden en dan de dinsdag enz.
Ik stuur u even mijn Macro.Sub hsv()
Dim i As Long, sn As String, cl As Range, ws As Worksheet, y As Long, c, sq As Long, myday
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Code: 
If Sheets.Count < 2 Then Exit Sub             'verwijderd de tabbladen 2 t/m een-na-laatste blad
 For i = Sheets.Count - 1 To 2 Step -1
  Sheets(i).Delete
 Next

With Sheets("Ledenlijst TSRM") 'maakt nieuwe tabbladen als ze nog niet bestaat.
'   .PageSetup.LeftHeader = "TSRM"
'   .PageSetup.CenterHeader = "Zwemgroep september 2012"
'   .PageSetup.RightHeader = "&D"
'   .PageSetup.Orientation = xlLandscape
.Range("A2:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("A1"), , .Range("C2"), , , , , xlGuess
sn = ""
  For Each cl In .Columns(3).SpecialCells(2).Offset(1)
    If InStr(1, sn, cl, vbTextCompare) = 0 Then
      .UsedRange.AutoFilter 3, cl
         sn = sn & "|" & cl
  Sheets.Add , Sheets(Sheets.Count - 1)
 
 With ActiveSheet                             'geeft het nieuwe blad de naam, de kopregel en de gegevens.
   .Name = cl
   .Cells(1, 1).Resize(, 20) = Split(Join(Application.Index(Sheets("Ledenlijst TSRM").Cells(1, 2).Resize(, 20).Value, 1, 0), "|"), "|")
    Sheets("Ledenlijst TSRM").AutoFilter.Range.Offset(1, 1).SpecialCells(12).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
     For y = 1 To 30
     Select Case Left(cl, 2)
      Case "MA"
        sq = 1
      Case "DI"
        sq = 2
      Case "WO"
        sq = 3
      Case "DO"
        sq = 4
      Case "VR"
        sq = 5
      Case "ZA"
        sq = 6
    End Select
     c = WorksheetFunction.Choose(sq, 2, 3, 4, 5, 6, 7)
     myday = y & "-9-2012"
        If Weekday(myday) = c Then
       .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = Format(myday, "d")
       End If
      Next y
   
   .Columns.AutoFit
   .PageSetup.LeftHeader = "TSRM"
   .PageSetup.CenterHeader = "Zwemgroep september 2012"
   .PageSetup.RightHeader = "&D" 'Format(Date, "dd-mm-yyyy")
   .PageSetup.Orientation = xlLandscape
   .PageSetup.PrintGridlines = True
End With
  
  .UsedRange.AutoFilter
     End If
    Next
  .Range("A2:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("B1"), , , , , , , xlGuess
   End With
  Sheets("Groepsleiders").UsedRange.Offset(1).ClearContents
 For Each ws In Worksheets
  If WorksheetFunction.And(ws.Name <> "Ledenlijst TSRM", ws.Name <> "Groepsleiders") Then
   With Sheets("Groepsleiders")
      .Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws.Name
      .Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = ws.Cells(Rows.Count, 2).End(xlUp).Row - 1
'      .PageSetup.LeftHeader = "TSRM"
'      .PageSetup.CenterHeader = "Zwemgroep september 2012"
'      .PageSetup.RightHeader = "&D"
'      .PageSetup.Orientation = xlLandscape
     End With
    End If
  Next
 Application.DisplayAlerts = True
Worksheets.PrintPreview
End Sub


Groeten,

Harry
 
Laatst bewerkt door een moderator:
Ik heb liever dat je je bestand upload met de code.
Graag codetags gebruiken om de code leesbaar te houden (selecteer de code en druk de #).

Het loopt bij mij redelijk goed moet ik zeggen.
Code: 
Sub hsv()
Dim i As Long, sn As String, cl As Range, ws As Worksheet, y As Long, c, sq, myday
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Sheets.Count < 2 Then Exit Sub             'verwijderd de tabbladen 2 t/m een-na-laatste blad
 For i = Sheets.Count - 1 To 2 Step -1
  Sheets(i).Delete
 Next
With Sheets("Ledenlijst TSRM") 'maakt nieuwe tabbladen als ze nog niet bestaat.
'   .PageSetup.LeftHeader = "Hallo"
'   .PageSetup.CenterHeader = "Harry"
'   .PageSetup.RightHeader = "&D"
'   .PageSetup.Orientation = xlLandscape
.Range("A2:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("A1"), , .Range("C2"), , , , , xlGuess
sn = ""
  For Each cl In .Columns(3).SpecialCells(2).Offset(1)
    If InStr(1, sn, cl, vbTextCompare) = 0 Then
      .UsedRange.AutoFilter 3, cl
         sn = sn & "|" & cl
  Sheets.Add , Sheets(Sheets.Count - 1)
 
 With ActiveSheet                             'geeft het nieuwe blad de naam, de kopregel en de gegevens.
   .Name = cl
   .Cells(1, 1).Resize(, 20) = Split(Join(Application.Index(Sheets("Ledenlijst TSRM").Cells(1, 2).Resize(, 20).Value, 1, 0), "|"), "|")
    Sheets("Ledenlijst TSRM").AutoFilter.Range.Offset(1, 1).SpecialCells(12).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
     For y = 1 To 30
     Select Case Left(cl, 2)
      Case "MA"
        sq = 2
      Case "DI"
        sq = 3
      Case "WO"
        sq = 4
      Case "DO"
        sq = 5
      Case "VR"
        sq = 6
      Case "ZA"
        sq = 7
    End Select
    
     myday = y & " September 2012"
        If Weekday(myday) = sq Then
       .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = myday
       .Cells(1, Columns.Count).End(xlToLeft).NumberFormat = "dd-mm-yyyy"
       End If
      Next y
   
   .Columns.AutoFit
   .PageSetup.LeftHeader = "Hallo"
   .PageSetup.CenterHeader = "Harry"
   .PageSetup.RightHeader = "&D"  'Datum vandaag
   .PageSetup.Orientation = xlLandscape
   .PageSetup.PrintGridlines = True
End With
  
  .UsedRange.AutoFilter
     End If
    Next
  .Range("A2:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort .Range("B1"), , , , , , , xlGuess
   End With
  Sheets("Groepsleiders").UsedRange.Offset(1).ClearContents
 For Each ws In Worksheets
  If WorksheetFunction.And(ws.Name <> "Ledenlijst TSRM", ws.Name <> "Groepsleiders") Then
   With Sheets("Groepsleiders")
      .Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws.Name
      .Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = ws.Cells(Rows.Count, 2).End(xlUp).Row - 1
'      .PageSetup.LeftHeader = "Hallo"
'      .PageSetup.CenterHeader = "Harry"
'      .PageSetup.RightHeader = "&D"
'      .PageSetup.Orientation = xlLandscape
     End With
    End If
  Next
 Application.DisplayAlerts = True
Worksheets.PrintPreview
End Sub
 

Bijlagen

Laatst bewerkt:
Ik weet niet wat ik fout heb gedaan maar nu doet hij het ook goed.

Ik heb de ledenlijst aangepast en de kolommen die vertrouwelijke gegevens hadden heb ik er uit gehaald.
Ook dan doet hij het goed.

Alsnog weer bedankt.

Harry
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan