Kolommen automatisch toevoegen en verwijderen

[KeBr]

Ik heb een bedrijfsplanning waarin de geplande uren van de medewerkers worden bijgehouden. op het tabblad "PROJ" vullen zij hun geplande uren voor het project in.
Op het tabblad totaal uren worden alle uren per medewerker verzameld. indien er meer dan 40 uur per week word dit rood weergegeven.
De sheet schuift elke week automatisch een week op, waarbij de voorgaande week nog in zicht blijft en de uren daarin lichtgrijs worden weergegeven.

De Vraag:
aan het eind van het jaar zijn er heel veel kolommen verborgen. voor het nieuwe jaar moet ik dan weer een kopie maken en dan eventueel uren overnemen.
Is het mogelijk om automatisch kolommen van voorbije weken te verwijderen en aan het eind nieuwe kolommen in te voegen zodat de sheet doorlopend word voor volgende jaren.
Zie ook de bijlage.

alvast bedankt

 

[KeBr]

Ik heb het zelf kunnen oplossen. onderstaande code heb ik in de sheet geplaatst. dit werkt naar behoren. werk dus in het eerder bijgevoegde bestand.

Private Sub Worksheet_Activate()
'
' kolommen_verplaatsen Macro
'

' Dim ("G2:BE2")as Range

While DatePart("ww", Range("G2").Value, vbMonday, vbFirstFourDays) < DatePart("ww", Date, vbMonday, vbFirstFourDays) - 10

Columns("G:G").Select
Selection.Cut
Columns("BE:BE").Select
Columns("BG:BG").Select
Selection.Insert Shift:=xlToRight
Range("BD2:BE2").Select
Selection.AutoFill Destination:=Range("BD2:BF2"), Type:=xlFillDefault
Range("BD2:BF2").Select
Range("BE1").Select
Selection.AutoFill Destination:=Range("BE1:BF1"), Type:=xlFillDefault
Range("BE1:BF1").Select
Range("BE3:BE60").Select
Selection.AutoFill Destination:=Range("BE3:BF60"), Type:=xlFillDefault
Range("BE3:BF60").Select
Wend
End Sub