Vba : Copier certaines colonnes autre feuille

Salut ccm81,
Si tu veux gagner en vitesse, déjà faut en voir l'utilité parce que sur 5000 lignes la différence n'est pas probante.
Cependant, pour gagner encore en vélocité, il faut essayer de ne plus accèder aux feuilles de calcul.
Ainsi, pour remplir un Objet Dictionary, tu gagneras du temps en passant d'abord par une variable tableau et de boucler sur ta variable (en mémoire) plutôt que sur ta feuille.
Donc, préférer :

Set mondico = CreateObject("Scripting.Dictionary")
   a = Range("a2:a" & [a65000].End(xlUp).Row)   ' tableau a(n,1) 
  For i = LBound(a) To UBound(a)
    mondico(a(i, 1)) = ""
  Next i

plutôt que :

Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("a2", [a65000].End(xlUp))
    mondico(c.Value) = ""
  Next c

Ensuite, s'agissant ici d'un fichier "Import", la question à se poser, enfin à poser à ArianeP, c'est l'évolution de son fichier...
Faut il supprimer les feuilles? Ajouter les nouvelles donénes en dessous de chacune?

est ce que ça vaut le coup?
On ne sait pas. Tout dépends de la destination de ce classeur.
S'il s'agit d'un import mensuel qu'il faut ventiler chaque fois dans les feuilles années, ça vaut certainement le coup que les données de février, mars etc se retrouvent dans les feuilles 2009, 2010 après les données de janvier.
D'où, dans le code que j'ai proposé, la ligne :

.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(DonneesFiltrees, 2), UBound(DonneesFiltrees, 1) + 1) = Application.Transpose(DonneesFiltrees)

Salut,
J'y regarde dans la journée.

De même, la ventilation des données en changeant de feuille quasiment à chaque ligne, te fait perdre 1 seconde.

  ' ventilation des données dans les feuilles annee
  For li = 1 To lifinFS - 1
    nomf = td(li, coannFS)
    lifinFV = Sheets(nomf).Cells(Rows.Count, codebFS).End(xlUp).Row
    For co = codebFS To cofinFS
      Sheets(nomf).Cells(lifinFV + 1, co).Value = td(li, co)
    Next co
  Next li

peut être avantageusement remplacé par :
1- une boucle sur les années (dico)
2- une boucle sur les données (td)
3- le remplissage d'un tableau de sortie
4- remplissage de la feuille "année" par un Resize = Application.transpose(tableaudesortie)
5- next année


En fait, le plus rapide, et je me répète ça aurait vraiment de l'importance sur 20 000 lignes et plus, serait :

Sub CopieColleA_D()
Dim FeuilleDepart As Worksheet, FeuilleArrivee As Worksheet
Dim DonneesInitiales(), DonneesFiltrees(), AnneesColC(), temp()
Dim MesAnnees As Object, Annee
Dim lig As Integer, Indice As Integer, i As Integer, col As Byte

Dim t
t = Timer
Set FeuilleDepart = ThisWorkbook.Worksheets("Feuil1") '==> A Adapter..........
With FeuilleDepart
    Set MesAnnees = CreateObject("Scripting.Dictionary")
    AnneesColC = .Range("C2", .Range("C" & Rows.Count).End(xlUp))
    For i = LBound(AnneesColC) To UBound(AnneesColC)
        MesAnnees(AnneesColC(i, 1)) = ""
    Next i
    temp = MesAnnees.keys
    'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm
    Call tri(temp, LBound(temp), UBound(temp))
    DonneesInitiales = .Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
For Each Annee In temp
    Indice = 1
    'http://www.developpez.net/forums/d269391/logiciels/microsoft-office/excel/macros-vba-excel/vba-e-feuille-existe/
    If FeuilleExiste(ThisWorkbook, CStr(Annee)) Then
        Set FeuilleArrivee = ThisWorkbook.Worksheets(CStr(Annee))
    Else
        ThisWorkbook.Worksheets.Add
        ActiveSheet.Name = Annee
        Set FeuilleArrivee = ThisWorkbook.Worksheets(CStr(Annee))
    End If
    For lig = LBound(DonneesInitiales) To UBound(DonneesInitiales)
        If DonneesInitiales(lig, 3) = Annee Then
            ReDim Preserve DonneesFiltrees(4, 1 To Indice)
            For col = 0 To 3
                DonneesFiltrees(col, Indice) = DonneesInitiales(lig, col + 1)
            Next col
            Indice = Indice + 1
        End If
    Next lig
    With FeuilleArrivee
        .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(DonneesFiltrees, 2), UBound(DonneesFiltrees, 1) + 1) = Application.Transpose(DonneesFiltrees)
    End With
Next Annee
MsgBox Timer - t
End Sub

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
'http://www.developpez.net/forums/d269391/logiciels/microsoft-office/excel/macros-vba-excel/vba-e-feuille-existe/
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

Sub tri(a, gauc, droi)
'http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm
Dim ref, g, d, temp
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      g = g + 1: d = d - 1
    End If
  Loop While g <= d
  If g < droi Then Call tri(a, g, droi)
  If gauc < d Then Call tri(a, gauc, d)
End Sub

Quoique je reste persuadé que l'on peux encore faire mieux.......

A suivre!