XL 2010 Couper coller entre feuilles d'un classeur

Option Explicit


Sub transfert()
Dim F1 As Range
Dim F2 As Worksheet
Dim i As Integer
Dim Desti
Dim DernLigneF1 As Long
Application.ScreenUpdating = False
DernLigneF1 = Sheets("source").Range("A" & Rows.Count).End(xlUp).Row
Set F1 = Sheets("source").Range("A1:A" & DernLigneF1)
Set F2 = Sheets("Archive")
For i = F1.Rows.Count To 4 Step -1
  If F1.Cells(i, 11).Value = "A" Then
    Set Desti = F2.[A65000].End(xlUp)
    Rows(i).EntireRow.Cut Destination:=Desti(2): Rows(i).EntireRow.Delete Shift:=xlUp
  End If
Next i
Range("a3").Select
ActiveWorkbook.Worksheets("Archive").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Archive").Sort.SortFields.Add Key:=Range("A3"), _
                                                         SortOn:=xlSortOnValues, _
                                                         Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Archive").Sort
  .SetRange Range("A4:M8")
  .Header = xlNo
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
Application.ScreenUpdating = True
End Sub