Cellen verwijderen/transporteren naargelang datum

[MBBS]

Ik weet niet of dit mogelijk is in excel maar ik probeer het toch maar

Ik zou volgende bewerkingen willen uitvoeren bij het openen van het werkblad.

Indien de datum in een cel voorbij is dan zouden de verwante cellen moeten worden gekopieerd naar een andere sheet en daarna gewist (ook de cellen zouden moeten worden verwijderd zodat alles opschuift naar boven).
Probleem is dat er geen volledige rijen kunnen worden gewist.
Indien het niet anders kan dan moet ik 3 verschillende sheets gaan maken en dat is waar ik nu even van af wil.

Ik denk dat het model in bijlage duidelijkheid zal scheppen.

 

[mcs51mc]

Sub GroepA()
Dim i As Long

    'Zoeken laaste datum
    i = 1
    Do
        i = i + 1
    Loop While Range("rngCornerA").Offset(i, 2) < Date
    
    'Kopiëren en plakken enkel uitvoeren wanneer data gevonden werd (i >2)
    If i > 2 Then
        'Gewenste range knippen en plakken in andere sheet
        Range(Range("rngCornerA").Offset(2, 0), Range("rngCornerA").Offset(i, 2)).Cut
        Sheets("GROEP_A").Select
        Range("A50000").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        
        'Terug in sheet "IN" de rijen verwijderen
        Sheets("IN").Select
        Range(Range("rngCornerA").Offset(2, 0), Range("rngCornerA").Offset(i, 2)).Delete Shift:=xlUp
    End If
End Sub

Met deze code kan je de data van "Groep A" verzetten naar werkblad van groep A en de rijen verwijderen in werkblad "In"
Wel zal je cel C9 de naam "rngCornerA" moeten geven.
Het resultaat van die code kan je terugvinden in bijgesloten file.
Merk op dat:
1) Die code niet automatisch start bij openen van de file
2) Die code enkel werkt op groep A
3) Er is niets voorzien voor die minimum 300 beschikbare nummers

Heb je hier iets aan?
Bekijk bijlage MBBS--2508(1)-V001.xls

 

[HSV]

Voor alle drie kolommen en bladen.
Als de code volstaat zet je het in Thisworkbook.open.

Sub hsv()
Dim x As Long
Dim j As Long
Dim i As Long
Dim E As Long
Dim M As Long
Dim U As Long
Dim c As String
   E = Cells(Rows.Count, 5).End(xlUp).Row
   M = Cells(Rows.Count, 13).End(xlUp).Row
   U = Cells(Rows.Count, 21).End(xlUp).Row
 
 Application.ScreenUpdating = False

ReDim A(11 To E, 11 To M, 11 To U) As Double
  j = 5
 For x = 1 To 3
 For i = UBound(A, x) To LBound(A, x) Step -1
   c = WorksheetFunction.Choose(x, "Groep_A", "Groep_B", "Groep_c")
If Cells(i, j) < Date Then
   Sheets(c).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 3) = Cells(i, j).Offset(, -2).Resize(, 3).Value
      Cells(i, j).Offset(, -2).Resize(, 3).Delete shift:=xlUp
   End If
  Next i
    With Sheets(c)
      .Range("A7:C" & .Cells(Rows.Count, 3).End(xlUp).Row).Sort .Range("A7")
    End With
   j = j + 8
  Next x
End Sub

 

[MBBS]

Hartelijk dank voor jullie inzet en inbreng.
Mijn probleem is "eindelijk" opgelost...

Ik kan nu mijn 101 macro's en tussenoplossingen achterwege laten.

THX