range kopieren en naam geven die in kolom B staat

[peterbelt]

Hoi,
Ik heb een formulier met 23 rijen 8 t/m 30 mijn bedoeling is om van iedere regel een nieuw werkblad maakt met de naam die is opgegeven in kolom c
en iedere keer als dezelfde persoon weer komt hij deze er ook bijzet via een knop.
en als het zou kunnen in kolom a automatisch de datum invult.
ik gebruik office 2007 en heb de bijlage erbij gedaan.
zou iemand er hier naar willen kijken ben er al de hele dag mee bezig en kom er niet uit.
Nu kopiert hij wel de namen uit kolom c maar geeft hij omdat er overal formulus instaan #verw weer .
zou hier iemand naar willen kijken?
Alvast bedankt
Groeten peter

Sub VerdeelEnHeers()

    Application.ScreenUpdating = False
    For Each c In Sheets("Rooster").Range("C8:C30")
        If WksExists(c.Value) Then
            Sheets("Rooster").Cells(c.Row, 1).Resize(, 14).Copy Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        Else
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = c.Value
                Sheets("Rooster").Rows(1).Copy .Cells(1)
                Sheets("Rooster").Cells(c.Row, 1).Resize(, 14).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End With
        End If
    Next c
    Sheets("Rooster").Select
    Application.ScreenUpdating = True
    
End Sub

Sub VerwijderSheets()

    Application.DisplayAlerts = False
    x = Sheets.Count
    For i = x To 2 Step -1
        Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Alvast bedankt.
Groeten peter

 

[RvanGalenLast]

Ik heb je code iets aangepast zodat het de hele range doorloopt, alle cellen met een "echte" waarde oppakt maar alle cellen met alleen een formule overslaat. Zie de vet gedrukte regel.

Sub VerdeelEnHeers()
Application.ScreenUpdating = False
    For Each c In Sheets("Rooster").Range("C8:C30")
        If WksExists(c.Value) Then
            Sheets("Rooster").Cells(c.Row, 1).Resize(, 14).Copy Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp).Offset(1)
[B]        ElseIf c.Value <> "" Then[/B]
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .Name = c.Value
                Sheets("Rooster").Rows(3).Copy .Cells(1)
                Sheets("Rooster").Cells(c.Row, 1).Resize(, 14).Copy .Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End With
        End If
Volgende:
    Next c
Sheets("Rooster").Select
Application.ScreenUpdating = True
End Sub

Ik neem aan dat het het tabblad "Rooster" wilt behouden bij het verwijderen van tabbladen? Dan de 2 in 3 veranderen.

Als je code plaatst dan graag tags (#) gebruiken.

 

[peterbelt]

Dank Je wel

Dank je wel Ronald ik ga hier mee aan de slag.
Groeten peter