Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglets

zendb · 5 Juin 2013

Bonjour,

j'ai besoin d'aide pour créer un listing pour un usage professionnel qui me ferai gagner pas mal de temps.

J'ai 12 onglets correspondant aux 12 mois de l'année. Chaque mois on liste des produits X qui nous sont retournés avec des dates de péremptions.

Je voudrais donc pouvoir regrouper dans un onglet toutes les lignes présentes dans mes 12 onglets répondant à deux critères :
- colonne L vide
- colonne F (date de péremption) > ou = à la date du jour.

Sauf que je vois pas du tout comment faire et j'aimerai votre aide ou orientation, merci

clapas · 5 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

bonjour,
Un petit exemple sous forme de fichier aurait été le bienvenu.
Pour ma part lorsque j'ai des données communes à plusieurs feuilles ou onglet je regroupe ces données dans une feuille nommée "paramètre" ( ou autre) . C'est à cette feuille que se réfère les formules, les validations de liste, etc
c'est peut être banal mais au moins je ne change que les données dans une seule feuille
Bon fin de journée
Clapas

job75 · 5 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Bonjour zendb, bienvenue sur XLD,

Il aurait été bien de joindre un fichier, mais on va faire sans.

C'est un problème très classique, il y a de nombreux exemples sur le forum.

Allez dans VBA (Alt+F11) et collez cette macro dans un Module :

Code:

Sub Regroupe()
'on suppose une ligne de titre en feuille "Regroupe"
Dim lig&, w As Worksheet, r As Range, v1, v2$
Application.ScreenUpdating = False
With Sheets("Regroupe") 'nom à adapter
  .Rows("2:" & .Rows.Count).Clear 'RAZ
  lig = 2
  For Each w In Worksheets
    If w.Name <> .Name Then
      For Each r In w.UsedRange.Rows
        v1 = Intersect(r.EntireRow, w.[F:F])
        v2 = Intersect(r.EntireRow, w.[L:L]).Text
        If IsDate(v1) Then
          If v1 >= Date And v2 = "" Then
            r.EntireRow.Copy .Cells(lig, 1)
            lig = lig + 1
          End If
        End If
      Next
    End If
  Next
  .Columns.AutoFit 'ajustement automatique
  .Activate 'facultatif
End With
End Sub

Pour la lancer vous pouvez par exemple l'affecter à un bouton.

J'ai supposé que la feuille qui regroupe les données s'appelle "Regroupe".

Nota : si les feuilles comportaient beaucoup de données on pourrait faire une macro bien plus rapide.

Mais il faudrait votre fichier.

Dites nous déjà ce qu'il en est.

Edit : salut clapas, je ne vous avais pas vu.

A+

zendb · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Bonjour et merci pour l'aide,

Voici un exemple de fichier que j'ai du modifier car il comporte initialement des données confidentielles.

niveau quantité de données j'ai 12 onglets (1 par mois) avec en moyenne 200 à 250 lignes par onglet, mais avec les dates de péremption les lignes qui seront "extraites" seront uniquement dans les derniers onglets car les dates sont courtes.

job75 · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Bonjour zendb,

Merci pour le fichier.

Il y a 3 lignes de titres, l'adaptation de la macro est facile :

Code:

Sub Regroupe()
Dim lig&, w As Worksheet, r As Range, v1, v2$
Application.ScreenUpdating = False
With Sheets("Regroupe") 'nom à adapter
  .Rows("4:" & .Rows.Count).Clear 'RAZ
  lig = 4 '1ère ligne renseignée
  For Each w In Worksheets
    If w.Name <> .Name Then
      For Each r In w.UsedRange.Rows
        v1 = Intersect(r.EntireRow, w.[F:F])
        v2 = Intersect(r.EntireRow, w.[L:L]).Text
        If IsDate(v1) Then
          If v1 >= Date And v2 = "" Then
            r.EntireRow.Copy .Cells(lig, 1)
            lig = lig + 1
          End If
        End If
      Next
    End If
  Next
  '.Columns.AutoFit 'ajustement automatique
  '.Activate 'facultatif
End With
End Sub

L'ajustement automatique de la largeur des colonnes n'est pas souhaitable ici.

La macro s'exécute quand on active la feuille "Regroupe" (clic droit sur l'onglet et Visualiser le code) :

Code:

Private Sub Worksheet_Activate()
Regroupe
End Sub

Fichier joint.

Nota : 250 lignes par feuille ce n'est pas beaucoup, en terme de rapidité cette macro devrait faire l'affaire.

Mais dites-nous quand même quelle est la durée d'exécution (approximative) sur votre fichier réel.

A+

zendb · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

ok ça fonctionne et c'est globalement assez rapide (moins d'une seconde).

Par contre est-il possible d'ajouter un 3em critère qui permettra d'exclure tous les faux positifs et certaines lignes qui ne devraient pas être récupérées dans le "regroupe".
C'est un critère sur la mise en forme des cellule : si un cellule (n'importe) est grisée alors la ligne est à exclure. Sauf que là encore en fonction des personnes utilisant le tableau il y a plusieurs nuances de gris utilisée : 25%, 40%, 50% et 80% ...
Si c'est possible ça serai top, ça permettrai d'assurer une fonctionnement de la macro indépendament de l'utilisateur et des personnes qui utilisent le fichier derrière

job75 · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Re,

Alors on va définir le 3ème critère ainsi : la cellule en colonne A doit être incolore ou colorée en blanc.

Voici la macro modifiée :

Code:

Sub Regroupe()
Dim lig&, w As Worksheet, r As Range, v1, v2$, coul&
Application.ScreenUpdating = False
With Sheets("Regroupe") 'nom à adapter
  .Rows("4:" & .Rows.Count).Clear 'RAZ
  lig = 4 '1ère ligne renseignée
  For Each w In Worksheets
    If w.Name <> .Name Then
      For Each r In w.UsedRange.Rows
        v1 = Intersect(r.EntireRow, w.[F:F])
        v2 = Intersect(r.EntireRow, w.[L:L]).Text
        coul = Intersect(r.EntireRow, w.[A:A]).Interior.ColorIndex
        If IsDate(v1) And (coul = xlNone Or coul = 2) Then
          If v1 >= Date And v2 = "" Then
            r.EntireRow.Copy .Cells(lig, 1)
            lig = lig + 1
          End If
        End If
      Next
    End If
  Next
End With
End Sub

Fichier (2).

A+

job75 · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Re,

Essayez cette macro, elle devrait être plus rapide :

Code:

Sub Regroupe()
Dim w As Worksheet, P As Range, r As Range, v1, v2$, coul&, lig&
Application.ScreenUpdating = False
With Sheets("Regroupe") 'nom à adapter
  .Rows("4:" & .Rows.Count).Clear 'RAZ
  For Each w In Worksheets
    If w.Name <> .Name Then
      Set P = Nothing
      For Each r In w.UsedRange.Rows
        v1 = Intersect(r.EntireRow, w.[F:F])
        v2 = Intersect(r.EntireRow, w.[L:L]).Text
        coul = Intersect(r.EntireRow, w.[A:A]).Interior.ColorIndex
        If IsDate(v1) And (coul = xlNone Or coul = 2) Then _
          If v1 >= Date And v2 = "" Then _
            Set P = Union(r, IIf(P Is Nothing, r, P))
      Next
      If Not P Is Nothing Then
        lig = Application.Max(4, .Cells(.Rows.Count, "F").End(xlUp).Row + 1)
        P.EntireRow.Copy .Rows(lig)
      End If
    End If
  Next
End With
End Sub

En effet, pour chaque feuille, le Copier-Coller se fait en bloc.

Fichier (3).

A+

zendb · 6 Juin 2013

Re : Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglet

Trop top ça fonctionne !

Un GRAND merci

Créer une liste à partir de critères et d'une plage étendue sur plusieurs onglets

zendb

XLDnaute Junior

clapas

XLDnaute Nouveau

job75

XLDnaute Barbatruc

zendb

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

zendb

XLDnaute Junior

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

zendb

XLDnaute Junior

Discussions similaires