Compter ligne avec un filtre + copier dans une feuille

Question

Je m'adresse à vous concernant un problème pour compter des lignes en utilisant un filtre et par la suite copier ma sélection. Le processus : - Dans le fichier "Exemple", vous trouverez 2 feuilles. Dans la feuille "Planning 2020", se trouve un tableau comportant sur la ligne 7 , des filtres. Dans mon cas, les seuls filtres que j'utilise sont ceux de la semaine 1,2,3 soit S01(Colonne M), S02(Colonne O) et S03(Colonne Q). - Si je commence par S01, je vais sur le filtre et je décoche la case "Vide" pour n'avoir que ce qui m'intéresse. - Une fois filtré, j'ai les infos qu'il me faut. Ce sont celles que je veux copier. (Voir photo "1", le cadre rouge que j'ai fait) : - Une fois ma sélection effectuée, j'aimerais juste la copier pour et la mettre dans la "feuil2" en Range("A1"). PROBLEME : Dans le titre j'ai inscris "compter lignes...". En effet, je pensais qu'en utilisant une boucle For comme à mes habitudes j'arriverais a me débrouiller sauf que....le filtre me bloque(puisque que dans ma boucle For , celui-ci compte toutes les lignes mêmes celles masquées par le filtres or je ne veux que les lignes filtrées ). Voici mon début de code quand j'appuie sur le bouton "MIF" en haut de la feuille "Planning 2020" : Private Sub Bt_MIF_Click() Dim dLig As Long, Lig As Long ' Désactiver le rafraichissement écran Application.ScreenUpdating = False ' Activer ce classeur ThisWorkbook.Activate ' Pas obligatoire ' Sur la feuille planning 2020 With ThisWorkbook.Sheets(1) .Activate 'Met un filtre ActiveSheet.Range("$D$7:$DL$117").AutoFilter Field:=10, Criteria1:="&lt;&gt;" ' Trouver la dernière ligne remplie dLig = .Range("F" & Rows.Count).End(xlUp).Row For Lig = 7 To dLig Next Lig End With End Sub REMARQUE : Evidemment, cela s'applique à la semaine 1 (S01), mais j'aimerais que le code soit adaptable et puisse se modeler par exemple pour la S02. Ceci dit, la transition pour passer de S01 à S02 puis à S03 je pense pouvoir me débrouiller. En vous souhaitant par avance, merci ! Bien cordialement...

xorsankukai · Accepted Answer

Bonjour MPETIT , le forum, Pas sûr d'avoir compris..... Est-ce le résultat souhaité ? Si oui, à tester..... Sub CopieSemainePlanning() Dim dl1 As Long, dc As Integer, j As Integer Application.ScreenUpdating = False Application.DisplayAlerts = False With Sheets("Feuil2") .Cells.Delete .Rows("1:1").Font.Bold = True End With With Sheets("Planning 2020") dl1 = .Range("C" & Rows.Count).End(xlUp).Row dc = Cells(7, Cells.Columns.Count).End(xlToLeft).Column j = 1 For i = 12 To dc Step 2 .Range("C7:Q" & dl1).AutoFilter Field:=i - 2, Criteria1:="&lt;&gt;" .Range(Cells(7, i), Cells(dl1, i)).SpecialCells(xlVisible).Copy Sheets("Feuil2").Cells(1, j).PasteSpecial Paste:=xlPasteValues If .FilterMode = True Then .ShowAllData j = j + 1 Next i End With Sheets("Feuil2").Activate Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Cordialement...

xorsankukai · Answer

Bonsoir MPETIT , le forum, A tester.... Sub copieLignesFiltrées() Dim dl1 As Long, dl2 As Long Application.ScreenUpdating = False Application.DisplayAlerts = False With Sheets("Feuil2") .Cells.Delete dl2 = .Range("A" & Rows.Count).End(xlUp).Row + 1 End With With Sheets("Planning 2020") dl1 = .Range("C" & Rows.Count).End(xlUp).Row '.Range("C7:Q" & dl1).AutoFilter Field:=10, Criteria1:="TRIM" 'j'ai fait le test en filtrant manuellement .Range("C4:Q" & dl1).SpecialCells(xlVisible).Copy Sheets("Feuil2").Range("A" & dl2) If .FilterMode = True Then .ShowAllData End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Cordialement...