Sub CopierFiltre(DeLaFeuille As String, CoinSupGaucheFiltre As String, _
NLignes As Long, ApartirLigne As Long, Ncolonnes As Long, _
Exclure1iereCol As Boolean, VersFeuille As String, VersCellule As String)
' paramètres:
' DeLaFeuille : nom dela feuille qui contient le filtre
' CoinSupGaucheFiltre : adresse de 1ère cellule du filtre en-têtes compris
' Nlignes : nombre de lignes filtrée à copier
' ApartirLigne : numero relatif de ligne à partir de laquelle on commence la copie
' ex: si ApartirLigne = 3 => on saute les deux premières lignes filtrées
' pour commencer la copie à 3 ième ligne des lignes visibles.
' Ncolonnes : nombre de colonnes à copier Y COMPRIS LA 1 IERE COLONNE !!!
' Exclure1iereCol : si FALSE, on copie aussi la 1ière colonne
' si TRUE, on ne copie pas la 1 ière colonne
' VersFeuille : nom de la feuille destination
' VesrCellule : adresse de la cellule de destination.
Dim V As Range, xArea As Range, i As Long, j As Long, N As Long
Dim DebutColFiltre As Long, DebutLigFiltre As Long, DerLig As Long
Dim NbrColCopier As Long, SauteLigne As Long
With Sheets(DeLaFeuille)
'Première colonne du filtre
DebutColFiltre = .Range(CoinSupGaucheFiltre).Column
'Première ligne des données du filtre
DebutLigFiltre = .Range(CoinSupGaucheFiltre).Row
'Dernière ligne filtrée visible
DerLig = .Cells(.Cells.Rows.Count, DebutColFiltre).End(xlUp).Row
'si aucune ligne visible ==> on ne fait rien
If DerLig <= DebutLigFiltre Then Exit Sub
'Range des cellules visibles à partir de la colonne DebutLigFiltre sur Ncolonnes
'1ière colonne (celle du filtre incluse)(ligne en-têtes exclue)
Set V = .Range(.Cells(DebutLigFiltre + 1, DebutColFiltre), .Cells(DerLig, DebutColFiltre))
If Exclure1iereCol Then
'On ne copie pas la 1ière colonne du filtre
NbrColCopier = Ncolonnes - 1
Set V = V.Offset(, 1).Resize(, NbrColCopier)
Else
'On copie aussi la 1ière colonne du filtre
NbrColCopier = Ncolonnes
Set V = V.Resize(, NbrColCopier)
End If
'On ne retient que les cellules visibles
Set V = V.SpecialCells(xlCellTypeVisible)
End With ' Sheets(DeLaFeuille)
'Déclaration du tableau résultat
ReDim TabResult(1 To NLignes, 1 To NbrColCopier)
'boucle sur les zones de V
N = 0: SauteLigne = 0
For Each xArea In V.Areas
'boucle sur les lignes d'une zone
For i = 1 To xArea.Rows.Count
'comptage lignes à sauter
SauteLigne = SauteLigne + 1
'Si plus de ligne à sauter => on traite
If SauteLigne >= ApartirLigne Then
'incrémentation d'une ligne du tableau résultat
N = N + 1
'si on est au moins à la 1ière ligne à copier
' alors Remplissage d'une ligne
For j = 1 To NbrColCopier
TabResult(N, j) = xArea(i, j).Value
Next j
End If
'si le nbre de lignes à copier a été atteint
If N = NLignes Then Exit For 'indice i
Next i
'si le nbre de lignes à copier a été atteint
If N = NLignes Then Exit For 'indice xArea
Next xArea
'Copie vers la feuille et cellule destination
Sheets(VersFeuille).Range(VersCellule).Resize(NLignes, NbrColCopier).Value = TabResult
End Sub
Sub TEST()
Sheets("windows").Range("A1:D" & Rows.Count).ClearContents
Sheets("1").Range("A1:D1").Copy Sheets("windows").Range("A1:D1")
Sheets("1").Range("A:A").AutoFilter Field:=1, Criteria1:="1"
CopierFiltre DeLaFeuille:="1", CoinSupGaucheFiltre:="A1", NLignes:=2, _
ApartirLigne:=3, Ncolonnes:=4, Exclure1iereCol:=False, _
VersFeuille:="windows", VersCellule:="A2"
Sheets("2").Range("B:B").AutoFilter Field:=1, Criteria1:="1"
CopierFiltre DeLaFeuille:="2", CoinSupGaucheFiltre:="B1", NLignes:=3, _
ApartirLigne:=1, Ncolonnes:=4, Exclure1iereCol:=False, _
VersFeuille:="windows", VersCellule:="A6"
Sheets("3").Range("G3:J1000").AutoFilter Field:=1, Criteria1:="1"
CopierFiltre DeLaFeuille:="3", CoinSupGaucheFiltre:="G3", NLignes:=2, _
ApartirLigne:=1, Ncolonnes:=4, Exclure1iereCol:=False, _
VersFeuille:="windows", VersCellule:="A10"
'Exemple : Le filtre ne renvoie aucune ligne
Sheets("4").Range("A:A").AutoFilter Field:=1, Criteria1:="99999"
CopierFiltre DeLaFeuille:="4", CoinSupGaucheFiltre:="A1", NLignes:=4, _
ApartirLigne:=1, Ncolonnes:=4, Exclure1iereCol:=False, _
VersFeuille:="windows", VersCellule:="A14"
End Sub