Extraction dans onglet différent selon couleur

[amdur]

Bonjour,

Je voudrais faire une extraction des lignes dans plusieurs onglets en fonction de la couleur de la cellule dans une colonne (dans mon exemple la colonne B).

Svp le but est de garder la trame de mon tableau avec les titres, sous-titres,... et d'extraire l'essentiel.

J'ai fait un exemple juste pour voir si une éventuelle macro pourrait marcher.

Merci par avance.

A bientôt.

 

[Staple1600]

Re : Extraction dans onglet différent selon couleur

Bonsoir à tous

amdur
ce qui manque à ton fichier exemple, c'est un onglet qui nous montre le résultat à obtenir pour une couleur (rouge par exemple)
(onglet que tu aurais fait manuellement)

 

[job75]

Re : Extraction dans onglet différent selon couleur

Bonjour amdur, hello JM,

Vous auriez pu créer les feuilles avec les résultats escomptés non ?

Alors brut de fonderie dans le ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 1 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) And c.Interior.ColorIndex <> code _
    Then c.EntireRow.Delete
Next
End Sub

La macro s'exécute quand on active une feuille.

Fichier joint.

A+

 

[Staple1600]

Re : Extraction dans onglet différent selon couleur

Bonsoir job75

Tu es trop bon 😉 (voir mon précédent message)

amdur
Tu vois, on est deux à attendre un fichier exemple plus étoffé 😉

 

[amdur]

Re : Extraction dans onglet différent selon couleur

Re,

Merci beaucoup job75, je vais la tester dans la semaine.

Staple1600, je vais finir par croire que tu m'en veux...

A bientôt.

 

[Staple1600]

Re : Extraction dans onglet différent selon couleur

Re


amdur
Pas du tout, Job75 et moi te réclamions la même chose afin de pouvoir voir quel résultat obtenir avant de proposer une macro.

Bonjour amdur, hello JM,
Vous auriez pu créer les feuilles avec les résultats escomptés non ?

Bonsoir à tous
amdur
ce qui manque à ton fichier exemple, c'est un onglet qui nous montre le résultat à obtenir pour une couleur (rouge par exemple)
(onglet que tu aurais fait manuellement)

C'est ta question, tu es libre de la "bâcler" ou pas. 😉
Plus on a de détails et explications , plus facile est la résolution de la question.

 

[job75]

Re : Extraction dans onglet différent selon couleur

Bonjour amdur, JM, le forum,

Si l'on veut aussi supprimer les titres inutiles ("Sous-critère") il faut être très précis :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range, sup As Boolean, flag As Boolean
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 2 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) Then
    If c.Interior.ColorIndex = code Then _
      flag = True Else sup = True
  Else
    If Not flag And (c(1, 0) Like "Sous*" Or _
      c(0, 0) Like "Sous*") Then sup = True
    If c(1, 0) Like "Sous*" Then flag = False
  End If
  If sup Then c.EntireRow.Delete: sup = False
Next
End Sub

Fichier (2).

A+

 

[job75]

Re : Extraction dans onglet différent selon couleur

Re,

En supprimant les lignes en bloc à la fin l'exécution est plus rapide :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim a, b, i, code, c As Range, flag As Boolean, sup As Range
a = Array("Jaune", "Vert", "Rouge", "Incolore")
b = Array(6, 10, 3, xlNone)
i = Application.Match(Sh.Name, a, 0)
If IsError(i) Then Exit Sub
code = b(i - 1)
Application.ScreenUpdating = False
Sh.Cells.Delete 'RAZ
Feuil1.UsedRange.EntireRow.Copy Sh.[A1] 'Feuil1 CodeName à adapter
For i = Sh.UsedRange.Rows.Count To 2 Step -1
  Set c = Sh.Cells(i, 2)
  If IsNumeric(CStr(c)) Then
    If c.Interior.ColorIndex = code Then _
      flag = True Else Set sup = Union(c, IIf(sup Is Nothing, c, sup))
  Else
    If Not flag And (c(1, 0) Like "Sous*" Or c(0, 0) Like "Sous*") _
      Then Set sup = Union(c, IIf(sup Is Nothing, c, sup))
    If c(1, 0) Like "Sous*" Then flag = False
  End If
Next
If Not sup Is Nothing Then sup.EntireRow.Delete
End Sub

Nota : avec Feuil1.UsedRange.EntireRow.Copy Sh.[A1] les hauteurs des lignes sont copiées.

Nouveaux fichiers joints.

A+