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

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
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*"...

Kushi

XLDnaute Nouveau
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 ?
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.
 

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
 

Kushi

XLDnaute Nouveau
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
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" ?
 

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
 

Kushi

XLDnaute Nouveau
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
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 !😁
 

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...
 

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
 

Kushi

XLDnaute Nouveau
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
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
 

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 936
Membres
101 844
dernier inscrit
pktla