Opgelost Samenvoegen gaat niet goed

[DeArie]

Ik heb pas geleden onderstaande code hier gekregen om tabbladen met dezelfde naam samen te voegen op basis van een datum in cel B4. Meestal werkt dat perfect maar kom nu ook een paar dingen tegen waarop hij toch niet doet wat hij zou moeten doen. Kan iemand mij uitleggen waarom hij dat doet?

Als ik de code gebruik in bijgevoegd bestand dan zet hij de oudste datum bovenaan ( vanaf regel 10 ) terwijl hij onderaan ingevoegd moet worden en hetzelfde doet hij ook met de datum die hij moet kopieëren in cel B4 dan zet hij de datum in/van cel A4 .

Sub Samenvoegen()
    Dim Klanten As New Collection   'Unieke klantnummers
    On Error Resume Next
    For Each sh In Sheets
        Klanten.Add Left(sh.Name, 6), Str(Left(sh.Name, 6))
    Next
    On Error GoTo 0
    
    For i = 1 To Klanten.Count
        klantnr = Klanten.Item(i)
        sheet1 = ""
        sheet2 = ""
        'Twee werkbladen voor dezelfde klant?
        For Each sh In Sheets
            If Left(sh.Name, 6) = klantnr Then
                If sheet1 = "" Then
                    sheet1 = sh.Name
                Else
                    sheet2 = sh.Name
                End If
            End If
        Next
        If sheet1 <> "" And sheet2 <> "" Then
            If Sheets(sheet1).Range("A4") > Sheets(sheet2).Range("A4") Then
                Combineren sheet1, sheet2
            Else
                Combineren sheet2, sheet1
            End If
        End If
    Next
    
       Application.CutCopyMode = False
End Sub

Sub Combineren(sheetVan, sheetNaar)     
    rnaar = Sheets(sheetNaar).Rows(Cells.Rows.Count).End(xlUp).Row + 1  "Hier kijk hij alvast naar het aantal rijen van het blad waar het naar toe geschreven moet gaan worden +1 regel extra?"
    Sheets(sheetVan).Range(Sheets(sheetVan).Rows(10), Sheets(sheetVan).Rows(Cells.Rows.Count).End(xlUp)).Copy  "Hier gaat hij de gegevens kopieëren vanaf het andere blad?"
    Sheets(sheetNaar).Rows(rnaar).Insert "hier voegt hij het gekopieërde in, aan de hand van de bovenstaande regel telling + 1 extra?"
    Sheets(sheetNaar).Range("B4") = Sheets(sheetVan).Range("B4") 'Datum aanpassen
    Application.DisplayAlerts = False
    Sheets(sheetVan).Delete
    Application.DisplayAlerts = True
    
End Sub

 

[AHulpje]

De datums in A4 zijn tekst i.p.v. datums.
In bijgaande versie wordt daar rekening mee gehouden:

If DateValue(Sheets(sheet1).Range("A4")) > DateValue(Sheets(sheet2).Range("A4")) Then

 

[DeArie]

@AHulpje thnx dit werkt