Code ne fonctionne pas

Bonjour,

je veux archiver des lignes d'un tableau d'une feuille dans une autre feuille avec le code suivant:

 Sheets("Tab").Activate
    Range("1:1").Select
        Colonne = Selection.Find(what:="BALN repositionnée", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Column
    fintableau = Range("a65536").End(xlUp).Row
     For i = 3 To fintableau

        If Not IsEmpty(Cells(i, Colonne)) Then
        Cells(i, Colonne).Select
        ActiveCell.EntireRow.Select
        Application.CutCopyMode = False
        Selection.Cut

        Sheets("Archivage").Select
        Sheets("Archivage").Activate
        YY = Range("b65536").End(xlUp).Row
        Cells(YY, 1).Offset(1, 0).Select

        ActiveSheet.Paste
        Sheets("Tab").Activate
        Selection.Delete Shift:=xlUp
        End If
     Next i

Le souci, c'est que alors que ma feuille Archivage est vierge, la variable YY qui devrait être à 1 pour le premier passage dans la boucle, est à 75 qui correspond en fait à la variable fintableau.

Bref, cela fait 2 heures que j'essaie en mode pas à pas et je ne comprends pas ce qui ne fonctionne pas.

Si quelqu'un veut bien pointer avec son doigt là où ça fait mal, ce serait super.

D'avance merci

Bonjour,

A tester..

Private Sub CommandButton1_Click()
Dim DerLigA As Long
    DerLigA = 3
    Application.ScreenUpdating = False
    With Sheets("Tab")
        For i = 3 To .Range("A" & Rows.Count).End(xlUp).Row
           If .Cells(i, 17) <> "" Then
           .Rows(i).Copy Sheets("Archivage").Rows(DerLigA)
           .Rows(i).Delete Shift:=xlUp
           DerLigA = DerLigA + 1
           End If
        Next i
    End With
End Sub

A+

Autre solution, évite d'aller trop bas dans la feuille. (Lignes réelles)

Private Sub CommandButton1_Click()
Dim DerLigA As Long
    DerLigA = 1
    Application.ScreenUpdating = False
    With Sheets("Tab")
        i = 3
        Do While Cells(i, 1) <> ""
            If .Cells(i, 17) <> "" Then
                .Rows(i).Copy Sheets("Archivage").Rows(DerLigA)
                .Rows(i).Delete Shift:=xlUp
                DerLigA = DerLigA + 1
            Else
                i = i + 1
            End If
        Loop
    End With
End Sub