XL 2019 copier uniquement les lignes souhaitées de façon auto

[desmonts]

Bonjour à toutes et tous.
Je souhaiterai copier que certaines lignes de l'onglet Feuil1 vers l'onglet "résultat souhaité" de façon automatique. Par exemple en colonne i de feuil1 je voudrais copier les 2 premières lignes de chaque "classe 1", les 3 premières lignes de chaque "classe 2", la première ligne chaque "classe 3" et les 4 premières lignes de chaque "classe 4".
Je vous ai mis un exemple dans le fichier Excel joint cela sera plus parlent. Est-ce que quelqu'un aurait une idée pour le faire de façon automatique?
Par avance merci de votre aide.
cdt,
Yohann

 

[fanch55]

Bonsoir,
Ce n'est surement pas le meilleur code, mais c'est une méthode qui peut vous être utile .

 

[desmonts]

Bonjour Fanch55,
merci pour ton retour c'est le résultat souhaité , le pb avec ta solution c'est que la colonne Brant est évolutive, il n' y aura pas que A,C,B mais une multitude de brant différentes, il faudrait donc la même chose mais que la macro détecte le changement de donnée dans la colonne brant. La colonne Brant sera tjs filtrée donc tous les A ensemble, tous les B ensemble tous les X ensemble etc..
En tout cas un grand merci pour ton aide,
cdt,
Yohann

 

[fanch55]

Corrigé et simplifié :

 

[job75]

Bonsoir desmonts, fanch55,

Voyez le fichier joint et cette macro affectée au bouton "Résultat" :

Sub Resultat()
Dim F As Worksheet
Set F = Sheets("Résultat")
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
F.Cells.Delete 'RAZ
'--copie les bonnes lignes---
With Sheets("Feuil1").[A1].CurrentRegion
    .Columns(10).EntireColumn.Insert 'insère une colonne auxiliaire
    .Columns(10) = "=1/OR(ROW()=1,OR(COUNTIFS(B$1:B1,B1,I$1:I1,""classe1"")={1;2}),OR(COUNTIFS(B$1:B1,B1,I$1:I1,""classe2"")={1;2;3}),COUNTIFS(B$1:B1,B1,I$1:I1,""classe3"")=1,OR(COUNTIFS(B$1:B1,B1,I$1:I1,""classe4"")={1;2;3;4}))"
    .Columns(10).SpecialCells(xlCellTypeFormulas, 1).EntireRow.Copy F.[A1]
    .Columns(10).EntireColumn.Delete 'supprime la colonne auxiliaire
End With
'---insère des lignes vides sur les résultats---
With F.[A1].CurrentRegion.Offset(2)
    .Columns(10) = "=1/(B3<>B2)" 'utilise la colonne auxiliaire
    .Columns(10).SpecialCells(xlCellTypeFormulas, 1).EntireRow.Insert
    .Columns(10).EntireColumn.Delete 'supprime la colonne auxiliaire
End With
F.Columns.AutoFit 'ajustement largeurs
With F.UsedRange: End With 'actualise les barres de défilement
F.Activate
End Sub

La formule qui permet de déterminer les bonnes lignes à copier n'est pas facile à comprendre...

Pour voir les formules mettez en commentaires les lignes qui suppriment la colonne auxiliaire.

A+

 

[desmonts]

Un grand merci Fanch55 et Job75, pour le tps que vous avez consacré, c'est exactement le résultat attendu.
Merci à vous 2.

 

[job75]

Bonjour desmonts, fanch55, le forum,

Une bien meilleure solution, voyez ce fichier (2) et la macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim ncol%, tablo, resu(), i&, n&, a, b, c, d, x$, j%
With Sheets("Feuil1").[A1].CurrentRegion
    .Sort .Columns(2), xlAscending, .Columns(9), , xlAscending, Header:=xlYes 'tri sur 2 colonnes
    ncol = IIf(.Columns.Count < 9, 9, .Columns.Count)
    tablo = .Resize(, ncol) 'matrice, plus rapide
End With
ReDim resu(1 To 2 * UBound(tablo), 1 To ncol)
For i = 2 To UBound(tablo)
    If i > 2 And tablo(i, 2) <> tablo(i - 1, 2) Then
        n = n + 1 'ligne de séparation
        a = 0: b = 0: c = 0: d = 0
    End If
    x = LCase(tablo(i, 9))
    If x = "classe1" Then If a < 2 Then a = a + 1: GoTo 1
    If x = "classe2" Then If b < 3 Then b = b + 1: GoTo 1
    If x = "classe3" Then If c < 1 Then c = c + 1: GoTo 1
    If x = "classe4" Then If d < 4 Then d = d + 1: GoTo 1
    GoTo 2
1   n = n + 1
    For j = 1 To ncol
        resu(n, j) = tablo(i, j)
    Next j
2 Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A2] '1ère cellule de destination, à adapter
    If n Then .Resize(n, ncol) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).ClearContents 'RAZ en dessous
    .EntireColumn.Offset(, ncol).Resize(Columns.Count - ncol - .Column).ClearContents 'RAZ à droite
End With
Columns.AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise les barres de défilement
End Sub

Pas besoin de bouton, elle se déclenche quand on active la feuille.

Elle est très rapide car elle utilise des tableaux VBA.

A+

 

[desmonts]

Super merci job75 c est parfait cela fonctionne.

 

[desmonts]

Re bonjour Job75
Je suis vraiment pas très doué, j'ai du rajouter 2 colonnes a mon fichier en B (supplier) et F (fonction), et impossible d'adapter ton code pour que cela fonctionne. Est-ce que tu pourrais m'aider stp. Par avance merci.
cdt,
Yohann

 

[job75]

Bonjour desmonts,

Effectivement c'est simple, remplacer 2 par 3 et 9 par 11 pour les numéros des colonnes, fichier (1).

Et on peut paramétrer ces numéros, fichier (2).

A+

 

[fanch55]

Salut le fil,

Et on peut paramétrer ces numéros, fichier (2).

Salut @job75,
personnellement, j'aurai mis ce code en début de sub :

Set R = Sheets("Feuil1").Cells.Find("Brand")
If R Is Nothing Then Exit Sub Else colBrand = R.Column
Set R = Sheets("Feuil1").Cells.Find("classes")
If R Is Nothing Then Exit Sub Else colClasses = R.Column
Set R = Nothing
Sheets("Feuil1").Rows(R.Row).Copy [A1]

Ainsi, @desmonts peut rajouter ou déplacer les colonnes autant qu'il veut.
La copie de la ligne 1 est nécessaire également, surtout si l'agencement a été modifié.
Mais il faudra qu'il mette les mains dans le code en cas de changement de nom de colonnes( comme c'est le cas du dernier fichier fourni: Brant --> Brand )

 

[job75]

@fanch55 : je ne pense pas que Desmonts va ajouter ou supprimer souvent des colonnes, il voulait juste savoir comment modifier la macro.

 

[desmonts]

Merci à tous pour vos réponses et en plus rapides , avec la modif job75 cela fonctionne parfaitement, quand je vais avoir un peu de tps je vais essayer de comprendre le code plus en détail pour pouvoir le modifier si j'ai besoin de faire des adaptations. En tout cas un grand merci à vous 2 et de façon plus général au forum également.