Macro om gegevens te kopiëren en daarna te verwijderen uit originele tabblad

[Sothest]

Goedemiddag iedereen,

Ik ben aan het proberen om een eenvoudige plannings Excel te maken voor iemand die niet erg pc minded is.

Bedoeling is dat hij via het eerste tabblad zijn projecten kan aanmaken, deze worden dan in het "planning" tabblad gezet en daar worden de projecten dan gevisualiseerd. Dit stuk is me gelukt.

Voor het tweede stuk zou ik ook graag hebben dat projecten gemakkelijk gearchiveerd kunnen worden, om het "planning" tabblad zou clean mogelijk te houden.
Daarom wou ik een Archief knop maken waarbij alle projecten met een reeds gepasseerde einddatum gekopieerd worden naar het "Archief" tabblad en ze worden verwijderd uit het "planning" tabblad.

Ik heb hiervoor wat code gevonden en deze aangepast voor de file, maar hij doet het niet 100%. Als ik de code stap voor stap doorloop via de editor, doet hij alles perfect. Maar als ik de macro uitvoer via de knop, stopt hij altijd na 2 lijnen.

Sub RijVerplaatsen()


Dim rij As Long
Dim n As Long
Dim src As Worksheet
Dim trg As Worksheet
Set src = Sheets("Planning")
Set trg = Sheets("Archief")
Application.ScreenUpdating = False
rij = trg.[A65536].End(xlUp).Row + 1

For n = 5 To Blad2.[A65536].End(xlUp).Row
If src.Cells(n, "G").Value < Date Then
Range(Cells(n, "A"), Cells(n, "G")).Copy
trg.Cells(rij, "A").PasteSpecial
Range(Cells(n, "A"), Cells(n, "F")).ClearContents

rij = rij + 1
End If
Next
Application.ScreenUpdating = True
End Sub

Bestand in bijlage.

Alvast bedankt voor de hulp!Bekijk bijlage Planning.zip

 

[VenA]

Voor het verplaatsen van het invulscherm naar de planning

Sub VenA()
With Sheets("Planning")
    .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 6) = Application.Transpose(Sheets("Invulscherm").Range("H3:H8").Value)
    .Cells(4, 1).CurrentRegion.Sort Range("E4"), Header:=xlYes
End With
End Sub

Van de planning naar het archief

Sub VenA1()
With Sheets("Planning")
    .Cells(4, 1).CurrentRegion.AutoFilter 7, "<" & Format(Date, "m-d-yyyy")
    With .Range("A5:G" & .Cells(Rows.Count, 1).End(xlUp).Row)
        .Copy Sheets("Archief").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Resize(, 6).ClearContents
    End With
    With .Cells(4, 1).CurrentRegion
        .AutoFilter 7, "<>"
        .Sort Range("E4"), Header:=xlYes
    End With
End With

 

[Sothest]

Beste VenA,

Die kan ik gebruiken. Heb er enkel nog een regeltje aan toegevoegd om die filter uit te zetten.

Heel erg bedankt!

 

[VenA]

Welk regeltje heb je toegevoegd? Aanpassen lijkt mij voldoende.

 

[Sothest]

ActiveSheet.ShowAllData

Ik weet niet hoe die autofilter aan te passen en dit werkt ook .