XL 2019 Copier Seulement les lignes affichée après un filtre de tableau

K

Kushi

XLDnaute Nouveau
Bonjour à tous !

J'espère que vous vous portez tous bien avec cette chaleur (pensez à vous hydrater c'est important),

Je viens faire appel à votre aide aujourd'hui pour la raison suivante :

Dans une macro, grâce à un bouton, je fais les manips suivante : Suppression de colonnes -> Création d'une liste de tri -> filtrer un tableau en fonction de cette liste -> copier / coller toutes les lignes filtrées -> compter le nombre de lignes différentes -> compacter les lignes identiques et les compter.

Je n'arrive pas à procéder à l'étape en rouge ci-dessus...J'ai ce code pour le moment, qui, me copie toutes les lignes une à une, mais la sélection de lignes seulement triées ne se fait pas... Puis il se pourrait suivant les configurations que je me retrouve avec plusieurs milliers de lignes donc la phase copier/coller lignes par lignes est très longue...

Pouvez -vous m'aider svp ?

PS : Mon code ci-dessous et le fichier test ci-joint

VB: 
Private Sub CommandButton1_Click()

    Range("M:N").Delete

ActiveWorkbook.Sheets("Feuil1").ListObjects.Add(xlSrcRange, Range("$M$1:$M$16"), , xlYes).Name = _
"Critères"
Range("M1").Value = "Ligne de Nomenclature"
Range("M2").Value = "*VIS*"
Range("M3").Value = "*ECROU*"
Range("M4").Value = "*HUCKLOK*"
Range("M5").Value = "*SCREW*"
Range("M6").Value = "*NUT*"
Range("M7").Value = "*WASHER*"
Range("M8").Value = "*RONDELLE*"
Range("M9").Value = "*BOM*"
Range("M10").Value = "*SIMAF*"
Range("M11").Value = "*RESSORT*"
Range("M12").Value = "*RIV.*"
Range("M13").Value = "*NORD-LOCK*"
Range("M14").Value = "*SCR.*"
Range("M15").Value = "*ECR.*"
Range("M16").Value = "*GOUPILLE*"

With ActiveSheet.ListObjects(1)
   .Range.AutoFilter
   .Range.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Feuil1").ListObjects("Critères").Range, Unique:=False
    
End With
        Sheets.Add.Name = "Feuil2"
        RowB01 = Worksheets("Feuil2").Cells(Rows.Count, 3).End(xlUp).Row + 1
        
i = 0
    Do While Worksheets("Feuil1").Range("I" & i + 1).Value <> ""
        Worksheets("Feuil1").Activate
            If Worksheets("Feuil1").Range("I" & i + 1) = Hidden = False Then Range("I1:K" & i + 1).Copy
            Worksheets("Feuil2").Activate
            Worksheets("Feuil2").Cells(RowB01, 1).PasteSpecial xlPasteValues
        i = i + 1
    Loop
        
    Dim nbligne As Integer
 
    nbligne = Sheets("Feuil2").Cells(Rows.Count, 3).End(xlUp).Row
 
    Sheets("Feuil2").Range("J1").Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
    
      Set mondico = CreateObject("Scripting.Dictionary")
  For Each c In Range("C3", [C65000].End(xlUp))
    mondico(c.Value) = mondico(c.Value) + 1
  Next c
  [E1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
  [F1].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)

        Columns("A:XFD").AutoFit
        
End Sub
 

Pièces jointes

  • test.xlsm
    32.8 KB · Affichages: 12
Solution
chris
RE

J'ai renommé le tableau "Nomenclature"

Une solution
VB: 
Private Sub CommandButton1_Click()

Range("M:N").Delete

ActiveWorkbook.Sheets("Feuil1").ListObjects.Add(xlSrcRange, Range("$M$1:$M$16"), , xlYes).Name = _
"Critères"
Range("M1").Value = "Ligne de Nomenclature"
Range("M2").Value = "*VIS*"
Range("M3").Value = "*ECROU*"
Range("M4").Value = "*HUCKLOK*"
Range("M5").Value = "*SCREW*"
Range("M6").Value = "*NUT*"
Range("M7").Value = "*WASHER*"
Range("M8").Value = "*RONDELLE*"
Range("M9").Value = "*BOM*"
Range("M10").Value = "*SIMAF*"
Range("M11").Value = "*RESSORT*"
Range("M12").Value = "*RIV.*"
Range("M13").Value = "*NORD-LOCK*"
Range("M14").Value = "*SCR.*"
Range("M15").Value = "*ECR.*"
Range("M16").Value = "*GOUPILLE*"...
Trier par date Trier par votes
K

Kushi

XLDnaute Nouveau
chris à dit:
Bonjour

Quand des ligne sont filtrées, par défaut la copie ne copie/colle que les lignes visibles

Quel est l’intérêt d'une boucle ici ?
Cliquez pour agrandir...
Bonjour Chris,

Justement non, enfin pour ma part ça ne fonctionne pas et le copier/coller, copie tout le tableau avant filtre...

La boucle ici est intervenue après beaucoup, beaucoup, beaucoup d'essais de copier/coller, au départ je n'avais pas ça 😅 mais le résultat reste le même...

Kushi.
 
Vote positif 0 Vote négatif
chris

chris

XLDnaute Barbatruc
RE

Ceci fonctionne parfaitement en ne copiant que 320 lignes et non les 422
VB: 
    Application.CutCopyMode = False
    Range("Tableau4[#All]").AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Range("Critères[[#All],[Ligne de Nomenclature]]"), Unique:= _
        False
    Range("Tableau4[#All]").Copy
    Sheets("Feuil2").Range("I1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
Vote positif 0 Vote négatif
K

Kushi

XLDnaute Nouveau
chris à dit:
RE

Ceci fonctionne parfaitement en ne copiant que 320 lignes et non les 422
VB: 
    Application.CutCopyMode = False
    Range("Tableau4[#All]").AdvancedFilter Action:=xlFilterInPlace, _
        CriteriaRange:=Range("Critères[[#All],[Ligne de Nomenclature]]"), Unique:= _
        False
    Range("Tableau4[#All]").Copy
    Sheets("Feuil2").Range("I1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Cliquez pour agrandir...
Chris,

Je viens d'essayer le code que tu m'a envoyé et ça me colle bien toute les valeurs du tableau non les 320 ...
Sais-tu d'où peut venir le "problème" ?
 
Vote positif 0 Vote négatif
chris

chris

XLDnaute Barbatruc
RE

J'ai renommé le tableau "Nomenclature"

Une solution
VB: 
Private Sub CommandButton1_Click()

Range("M:N").Delete

ActiveWorkbook.Sheets("Feuil1").ListObjects.Add(xlSrcRange, Range("$M$1:$M$16"), , xlYes).Name = _
"Critères"
Range("M1").Value = "Ligne de Nomenclature"
Range("M2").Value = "*VIS*"
Range("M3").Value = "*ECROU*"
Range("M4").Value = "*HUCKLOK*"
Range("M5").Value = "*SCREW*"
Range("M6").Value = "*NUT*"
Range("M7").Value = "*WASHER*"
Range("M8").Value = "*RONDELLE*"
Range("M9").Value = "*BOM*"
Range("M10").Value = "*SIMAF*"
Range("M11").Value = "*RESSORT*"
Range("M12").Value = "*RIV.*"
Range("M13").Value = "*NORD-LOCK*"
Range("M14").Value = "*SCR.*"
Range("M15").Value = "*ECR.*"
Range("M16").Value = "*GOUPILLE*"

Sheets.Add.Name = "Feuil2"

With Range("Nomenclature").ListObject
    Application.CutCopyMode = False
    .Range.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("Critères[[#All],[Ligne de Nomenclature]]"), CopyToRange:=Worksheets("Feuil2").Range("I1"), _
        Unique:=False
End With

With Worksheets("Feuil2")
    .Columns("I:K").Style = "Normal"
    Dim nbligne As Integer
    nbligne = WorksheetFunction.CountA(.Columns(9)) - 1

    .Range("J2").Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
    
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In .Range("C2:C" & nbligne + 1)
        mondico(c.Value) = mondico(c.Value) + 1
    Next c
    .[E1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
    .[F1].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)

    .Columns("A:XFD").AutoFit
End With
        
End Sub
 
Vote positif 0 Vote négatif
Solution
K

Kushi

XLDnaute Nouveau
chris à dit:
RE

J'ai renommé le tableau "Nomenclature"

Une solution
VB: 
Private Sub CommandButton1_Click()

Range("M:N").Delete

ActiveWorkbook.Sheets("Feuil1").ListObjects.Add(xlSrcRange, Range("$M$1:$M$16"), , xlYes).Name = _
"Critères"
Range("M1").Value = "Ligne de Nomenclature"
Range("M2").Value = "*VIS*"
Range("M3").Value = "*ECROU*"
Range("M4").Value = "*HUCKLOK*"
Range("M5").Value = "*SCREW*"
Range("M6").Value = "*NUT*"
Range("M7").Value = "*WASHER*"
Range("M8").Value = "*RONDELLE*"
Range("M9").Value = "*BOM*"
Range("M10").Value = "*SIMAF*"
Range("M11").Value = "*RESSORT*"
Range("M12").Value = "*RIV.*"
Range("M13").Value = "*NORD-LOCK*"
Range("M14").Value = "*SCR.*"
Range("M15").Value = "*ECR.*"
Range("M16").Value = "*GOUPILLE*"

Sheets.Add.Name = "Feuil2"

With Range("Nomenclature").ListObject
    Application.CutCopyMode = False
    .Range.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("Critères[[#All],[Ligne de Nomenclature]]"), CopyToRange:=Worksheets("Feuil2").Range("I1"), _
        Unique:=False
End With

With Worksheets("Feuil2")
    .Columns("I:K").Style = "Normal"
    Dim nbligne As Integer
    nbligne = WorksheetFunction.CountA(.Columns(9)) - 1

    .Range("J2").Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
   
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In .Range("C2:C" & nbligne + 1)
        mondico(c.Value) = mondico(c.Value) + 1
    Next c
    .[E1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
    .[F1].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)

    .Columns("A:XFD").AutoFit
End With
       
End Sub
Cliquez pour agrandir...
Merci beaucoup Chris pour ta solution, j'ai essayé ça fonctionne bien !

C'est le tableau que tu as renommé une fois filtré c'est ça ?

Merci encore pour le temps que tu as pu y passer !😁
 
Vote positif 0 Vote négatif
chris

chris

XLDnaute Barbatruc
RE

Non.

On ne garde pas les noms automatiques de type Tableau4 : on renomme toujours avec des noms signifiants. J'ai donc remplacé Tableau4 par Nomenclature avant filtre

De même il est conseillé de renommer ses onglets

J'ai essayé plusieurs solutions mais effectivement il y a un comportement bizarre avec le filtre sur place + copie...
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Bonjour à tous,
J'ai cliqué sur Répondre trop tard ...
Une solution alternative :
VB: 
Function IsSheet(FName As String) As Boolean
    On Error Resume Next
    IsSheet = Not Worksheets(FName) Is Nothing
End Function
Private Sub CommandButton1_Click()
Dim Crit(), nbligne
    Crit = Array("*VIS*", "*ECROU*", "*HUCKLOK*", "*SCREW*", "*NUT*", "*WASHER*", _
                 "*RONDELLE*", "*BOM*", "*SIMAF*", "*RESSORT*", "*RIV.*", "*NORD-LOCK*", _
                 "*SCR.*", "*ECR.*", "*GOUPILLE*")
    
    If Me.FilterMode Then Me.ShowAllData
    
    If Not [Critères].ListObject.DataBodyRange Is Nothing Then [Critères].ListObject.DataBodyRange.Delete
    [Critères[#Data]].Resize(UBound(Crit) + 1) = Application.Transpose(Crit)
    [Critères[#Headers]].Columns.AutoFit
    
    [Tableau4].ListObject.Range.AdvancedFilter _
        Action:=xlFilterInPlace, CriteriaRange:=[Critères].ListObject.Range, Unique:=False
        
    If Not IsSheet("Feuil2") Then Worksheets.Add.Name = "Feuil2"
    With Worksheets("Feuil2")
        .Activate
        .Cells.Clear
        [Tableau4].ListObject.Range.SpecialCells(xlCellTypeVisible).Copy .[A2]
        .Columns.AutoFit
        nbligne = .Cells(.Rows.Count, 3).End(xlUp).Row
        .[J1].Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
    End With
    
    If Me.FilterMode Then Me.ShowAllData
End Sub

Par contre j'ai pas compris la formule en J1 ni l'utilité des Dico
 
Vote positif 0 Vote négatif
K

Kushi

XLDnaute Nouveau
fanch55 à dit:
Bonjour à tous,
J'ai cliqué sur Répondre trop tard ...
Une solution alternative :
VB: 
Function IsSheet(FName As String) As Boolean
    On Error Resume Next
    IsSheet = Not Worksheets(FName) Is Nothing
End Function
Private Sub CommandButton1_Click()
Dim Crit(), nbligne
    Crit = Array("*VIS*", "*ECROU*", "*HUCKLOK*", "*SCREW*", "*NUT*", "*WASHER*", _
                 "*RONDELLE*", "*BOM*", "*SIMAF*", "*RESSORT*", "*RIV.*", "*NORD-LOCK*", _
                 "*SCR.*", "*ECR.*", "*GOUPILLE*")
   
    If Me.FilterMode Then Me.ShowAllData
   
    If Not [Critères].ListObject.DataBodyRange Is Nothing Then [Critères].ListObject.DataBodyRange.Delete
    [Critères[#Data]].Resize(UBound(Crit) + 1) = Application.Transpose(Crit)
    [Critères[#Headers]].Columns.AutoFit
   
    [Tableau4].ListObject.Range.AdvancedFilter _
        Action:=xlFilterInPlace, CriteriaRange:=[Critères].ListObject.Range, Unique:=False
       
    If Not IsSheet("Feuil2") Then Worksheets.Add.Name = "Feuil2"
    With Worksheets("Feuil2")
        .Activate
        .Cells.Clear
        [Tableau4].ListObject.Range.SpecialCells(xlCellTypeVisible).Copy .[A2]
        .Columns.AutoFit
        nbligne = .Cells(.Rows.Count, 3).End(xlUp).Row
        .[J1].Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
    End With
   
    If Me.FilterMode Then Me.ShowAllData
End Sub

Par contre j'ai pas compris la formule en J1 ni l'utilité des Dico
Cliquez pour agrandir...
Bonjour fanch55,

Merci beaucoup pour ta solution également !!
L'utilité de la formule en J1 est pour savoir le nombre de ligne différentes que comporte le tableau collé.
tandis que l'utilité des dico c'est pour "supprimer" les doublons des lignes et les compter...

Je suis seulement débutant en VBA j'essaie de trouver le maximums de solutions par ci par là... 😅

J'ai donc remis les Dicos avec les bonnes cellules pour que tu vois comment ça fait... (si tu veux voir)

Merci encore ^^
VB: 
Function IsSheet(FName As String) As Boolean
    On Error Resume Next
    IsSheet = Not Worksheets(FName) Is Nothing
End Function
Private Sub CommandButton1_Click()
Dim Crit(), nbligne
    Crit = Array("*VIS*", "*ECROU*", "*HUCKLOK*", "*SCREW*", "*NUT*", "*WASHER*", _
                 "*RONDELLE*", "*BOM*", "*SIMAF*", "*RESSORT*", "*RIV.*", "*NORD-LOCK*", _
                 "*SCR.*", "*ECR.*", "*GOUPILLE*")
    
    If Me.FilterMode Then Me.ShowAllData
    
    If Not [Critères].ListObject.DataBodyRange Is Nothing Then [Critères].ListObject.DataBodyRange.Delete
    [Critères[#Data]].Resize(UBound(Crit) + 1) = Application.Transpose(Crit)
    [Critères[#Headers]].Columns.AutoFit
    
    [Tableau4].ListObject.Range.AdvancedFilter _
        Action:=xlFilterInPlace, CriteriaRange:=[Critères].ListObject.Range, Unique:=False
        
    If Not IsSheet("Feuil2") Then Worksheets.Add.Name = "Feuil2"
    With Worksheets("Feuil2")
        .Activate
        .Cells.Clear
        [Tableau4].ListObject.Range.SpecialCells(xlCellTypeVisible).Copy .[A1]
        .Columns.AutoFit
        nbligne = .Cells(.Rows.Count, 3).End(xlUp).Row
        .[J1].Formula = "=SUMPRODUCT(1/COUNTIF(Feuil2!C2:C" & nbligne & ",Feuil2!C2:C" & nbligne & "))"
        
    Set mondico = CreateObject("Scripting.Dictionary")
    For Each c In .Range("C2:C" & nbligne + 1)
        mondico(c.Value) = mondico(c.Value) + 1
    Next c
    .[E1].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)
    .[F1].Resize(mondico.Count, 1) = Application.Transpose(mondico.items)
    
    .Columns("A:XFD").AutoFit

    End With
    
    If Me.FilterMode Then Me.ShowAllData
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
1 K
Dranreb
Dranreb
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
2 K
thivame
T
I
  • Question
Microsoft 365 SOMMEPROD en vba excel
Réponses
12
Affichages
445
iliess
I
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
447
GClaire
G
Y
  • Question
Microsoft 365 récupérer données de tableau structuré sur une plage
Réponses
2
Affichages
501
jpb388
jpb388
K
  • Résolu(e)
XL 2019 ListObjects -- Erreur 1004
Réponses
3
Affichages
741
patricktoulon
patricktoulon
chris6999
  • Question
Microsoft 365 Boucle VB pour supprimer les caractères spéciaux et numériques d'une chaîne
Réponses
5
Affichages
370
patricktoulon
patricktoulon
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
329
souhaib ad
S
G
  • Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
G
  • Question
Microsoft 365 Incompatibilité de type - Array
Réponses
2
Affichages
427
guiyom
G

Membres actuellement en ligne

18 membres et 245 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 841
Messages
2 113 482
Membres
111 877
dernier inscrit
thierry@1965