Extraction de base sur nouveau fichier selon 3 critères

Julie-F

Julie-F

XLDnaute Occasionnel
Bonsoir à tous


J'ai un gros souci avec une base.
Je souhaiterais pouvoir à partir d'une base (extract base.xls) pouvoir crééer dans un nouveau classeur : 4 onglets reprenant un certain nombre d'infos de la base. Ces nouveaux tableaux seraient subordonnés à 3 critères d'une part mais en plus les données ainsi récupérées devraient être triées (pour 3 colonnes) par ordre croissant.
Mais je ne parviens pas à cumuler toutes ces contraintes.

Quelqu'un pourrait il m'apporter ses lumières ?
Là, je bloque
 

Pièces jointes

  • Extract Base.xls
    24.5 KB · Affichages: 84
  • Classeur souhaité.xls
    15 KB · Affichages: 58
Trier par date Trier par votes
KenDev

KenDev

XLDnaute Impliqué
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour Julie,

Un code qui marche sur Excel 2007, pour 2003 j'ai un doute avec la ligne :
Code: 
If WorksheetFunction.IsText(oDaz.Cells(i, Cl(3))) = Flt(k, 2) Then
Si ça va pas, on tachera de trouver autre chose...:) Fichier Joint

Cordialement

KD

Edit : Oups; le tri... corrigé dans code & fichier

Edit 2 : Si la ligne précitée passe pas la remplacer par celle là
VB: 
If Len(oDaz.Cells(i, Cl(3))) > 0 = Flt(k, 2) Then

VB: 
Option Explicit

Sub ExtractBaseJ()
Dim Rw As Long, oDaz As Worksheet, Cl() As Long, i As Long, cNew As Workbook, cBase As Workbook
Dim ClC() As Long, Tableau() As Variant, Cpt As Long, j As Long, Flt() As Variant, k As Byte

    Application.ScreenUpdating = False
    Workbooks("Extract Base J.xls").Activate
    Set cBase = ActiveWorkbook
    Application.Workbooks.Add
    Set cNew = ActiveWorkbook
    Sheets.Add
    cBase.Activate
    Set oDaz = cBase.Worksheets("Bat DAZ")
    Rw = oDaz.Cells(Rows.Count, 32).End(xlUp).Row '<- remplacer 32 par le numéro d'une colonne toujours non vide (au pire écrire en dur n° derniere ligne de la base)
 
    'colonnes critères
    ReDim Cl(1 To 3): Cl(1) = 32: Cl(2) = 30: Cl(3) = 28
    'colonnes à copier
    ReDim ClC(1 To 15)
    ClC(1) = 26: ClC(2) = 27: ClC(3) = 2: ClC(4) = 3: ClC(5) = 4: ClC(6) = 7: ClC(7) = 8: ClC(8) = 10
    ClC(9) = 19: ClC(10) = 20: ClC(11) = 28: ClC(12) = 30: ClC(13) = 31: ClC(14) = 32: ClC(15) = 33
    'tableau conditions
    ReDim Flt(1 To 4, 1 To 2)
    Flt(1, 1) = 1: Flt(2, 1) = 1: Flt(3, 1) = "": Flt(4, 1) = ""
    Flt(1, 2) = False: Flt(2, 2) = True: Flt(3, 2) = False: Flt(4, 2) = True
    
For k = 1 To 4

    'construction tableau à copier
    ReDim Tableau(1 To 15, 1 To 1)
    Cpt = 1
    For i = 1 To 15
        Tableau(i, 1) = oDaz.Cells(2, ClC(i))
    Next i

    'exploration de la base
    For i = 3 To Rw
        If Trim(oDaz.Cells(i, Cl(1))) = "oui" Then
            If oDaz.Cells(i, Cl(2)) = Flt(k, 1) Then
                If WorksheetFunction.IsText(oDaz.Cells(i, Cl(3))) = Flt(k, 2) Then
                    Cpt = Cpt + 1
                    ReDim Preserve Tableau(1 To 15, 1 To Cpt)
                    For j = 1 To 15
                        Tableau(j, Cpt) = oDaz.Cells(i, ClC(j))
                    Next j
                End If
            End If
        End If
    Next i
    
    'écritures
    For i = 1 To Cpt
        For j = 1 To 15
            cNew.Worksheets(k).Cells(i + 1, j + 1) = Tableau(j, i)
        Next j
    Next i
    cNew.Worksheets(k).Name = "Ong" & k

'tri
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 2), Cells(Cpt + 1, 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 3), Cells(Cpt + 1, 3)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 4), Cells(Cpt + 1, 4)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With cNew.Worksheets(k).Sort
        .SetRange Range(Cells(2, 2), Cells(Cpt + 1, 16))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
Next k
    
    Set cBase = Nothing
    Set cNew = Nothing
    Set oDaz = Nothing
    Application.ScreenUpdating = True
    
End Sub
 

Pièces jointes

  • EBJ.zip
    22 KB · Affichages: 47
Dernière édition:
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour KenDev,

Génial.
Il semble qu'il n'y ait pas de blocage au niveau de la ligne citée mais le débocage se met en route au moment du tri sur xlSortOnValues avec le message suivant : Erreur de compil Variabl non définie

Code: 
 'tri
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 2), Cells(Cpt + 1, 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal


Et j'ignore d'où vient le problème
Peut-on définir préalablement le nom du nouveau classeur (type : récup.xls) contenant les 4 nouveaux onglets ?
 
Vote positif 0 Vote négatif
JNP

JNP

XLDnaute Barbatruc
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour le fil :),
Le problème vient de la méthode Sort, celle-ci a beaucoup changé entre 2003 et 2007 :p...
2003 : tri limité à 3 critères
2007 : tri illimité :rolleyes:...
Du fait, le codage est fortement différent : 2007
Code: 
   cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 2), Cells(Cpt + 1, 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 3), Cells(Cpt + 1, 3)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    cNew.Worksheets(k).Sort.SortFields.Add Key:=Range(Cells(3, 4), Cells(Cpt + 1, 4)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With cNew.Worksheets(k).Sort
        .SetRange Range(Cells(2, 2), Cells(Cpt + 1, 16))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
2003 devrait ressembler à ça (sans garantie :eek:)
Code: 
   cNew.Worksheets(k).Range(Cells(2, 2), Cells(Cpt + 1, 16)).Sort Key1:=Range(Cells(3, 2), Cells(Cpt + 1, 2)), _
        Order1:=xlAscending, DataOption1:=xlSortNormal, Key2:=Range(Cells(3, 3), Cells(Cpt + 1, 3)), _
        Order2:=xlAscending, DataOption2:=xlSortNormal, Key3:=Range(Cells(3, 4), Cells(Cpt + 1, 4)), _
        Order3:=xlAscending, DataOption3:=xlSortNormal, Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom
si mon code n'est pas bon, je te conseilles d'utiliser l'enregistreur de macro pour voir où je me suis trompé :rolleyes:...
Bon dimanche :cool:
 
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour Julie, bonjour JNP,

@JNP : Merci pour le tri

@Julie : Pour le nom du nouveau classeur, je propose d'ajouter 1 variable et deux lignes :
Code: 
Dim Pth as string
puis sous
Code: 
Set cBase = ActiveWorkbook
ajouter
VB: 
Pth = ThisWorkbook.Path
.
Sous
Code: 
Next k
ajouter
VB: 
cNew.SaveAs Pth & "\Recup.xls"
Le classeur Récup sera créé dans le même répertoire que Extract Base.

Cordialement

KD
 
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour JNP,

Lorsque je remplace la macro de Kendev par la tienne, j'obtiens également un message d'erreur
Erreur d'exécution 1004, erreur définie par l'application ou par l'objet.
J'ai essayé de faire comme tu me l'as conseillée c à d recours à l'enregistreur de macro mais la difficulté que je rencontre c'est ce double tri, le 2eme tri étant subordonné aux valeurs issues du 1er tri (colonne Z = tri croissant).
Je m'explique, au niveau des onglets créés : je dois trier la colonne Z par ordre croissant puis la colonne AA (elle aussi par ordre croissant) mais ce 2ème tri est fonction de la valeur de Z. Chaque fois que ma valeur en Z est identique, je vais trier l'ensemble des valeurs de AA.
Mon tableau base est évolutif et je ne peux pas définir préalablement les zones de tri en colonne AA puisque j'ignore qu'elles seront les lignes où les valeurs de ma colonne Z changeront. Les tris devant pour 2 onglets être concomitants.

Je joins le tableau de Kendev ainsi que le classeur comprenant le résultat souhaité.
 

Pièces jointes

  • Extract2 - Résultats souhaités.zip
    33.4 KB · Affichages: 39
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

KenDev à dit:
Bonjour Julie, bonjour JNP,

@JNP : Merci pour le tri

@Julie : Pour le nom du nouveau classeur, je propose d'ajouter 1 variable et deux lignes :

.........

Le classeur Récup sera créé dans le même répertoire que Extract Base.

Cordialement

KD
Cliquez pour agrandir...

Bonjour Kendev,

Tellement obnubilée par mon problème de classement que je ne parviens pas à résoudre, je n'avais pas vu que tu avais posté. :eek:
Génial encore une fois, çà fonctionne. Merci beaucoup.

Toujours un message d'erreur dans la macro (même en passant par l'enregistrement d'une macro) au moment du tri :(
 
Dernière édition:
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Je ne parviens toujours pas à effectuer mes tris sur les 4 nouveaux onglets à partir de la macro principale.

Dans le classeur récup. la macro tri me donne ceci et çà semble fonctionner

Code: 
Sheets("Ong1").Select
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("C3") _
        , Order2:=xlAscending, Key3:=Range("D3"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
        
        Sheets("Ong2").Select
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("C3") _
        , Order2:=xlAscending, Key3:=Range("D3"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
        
        Sheets("Ong3").Select
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("C3") _
        , Order2:=xlAscending, Key3:=Range("D3"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
        
        
           Sheets("Ong4").Select
    Cells.Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("C3") _
        , Order2:=xlAscending, Key3:=Range("D3"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal


Mais dès que j'essaie de l'incorporer dans la macro contenant ma base, j'ai des messages d'erreurs.

Pourriez-vous m'aider ?
 
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonsoir Julie,

Un nouvel essai qui passe chez moi, j'ai essayé de respecter la syntaxe 2003 que tu as donné. A voir

Cordialement

KD
 

Pièces jointes

  • EBJ21.zip
    23.3 KB · Affichages: 31
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonsoir KenDev

Merci beaucoup pour ton aide.
J'ai testé ta nouvelle macro mas il y a un problème sur le 3ème onglet.

Le tri se fait correctement malheureusement le titre des colonnes est également trié et se retrouve de ce fait soit en fin de tableau (dans mon fichier, le problème se retrouve dans l'onglet 1 et 3) ou au milieu dans le tien que je mets en pièce jointe (avec fichier recup.xls)

Sais-tu d'où cela peut provenir ?
 

Pièces jointes

  • EBJ21 - ONGLETS.zip
    24.2 KB · Affichages: 36
Dernière édition:
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Extraction de base sur nouveau fichier selon 3 critères

Oui.... Dans cet onglet, colonne 2 en plus de chiffres on rencontre des '---', ce qui fait Excel ne reconnait pas un type de donnée particulier et dans le doute, tri tout. Remplace juste dans le paragraphe
VB: 
oRng.Sort Key1:=oRgA, Order1:=xlAscending, Key2:=oRgB _
        , Order2:=xlAscending, Key3:=oRgC, Order3:=xlAscending, Header:= _
        xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
XlNo par XlYes.

Pour revenir à mon premier post, je te consille de remplacer
VB: 
If WorksheetFunction.IsText(oDaz.Cells(i, Cl(3))) = Flt(k, 2) Then
par
VB: 
If Len(oDaz.Cells(i, Cl(3))) > 0 = Flt(k, 2) Then
. La première présuppose que la colonne concernée ne peut contenir du texte et se base la dessus pour prendre sa décision (je m'étais basé sur les exemples de données), alors que la 2ème se base effectivement sur le critère vide ou pas (ce qui était demandé).

Cordialement

KD
 
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour Kendev

La macro s'exécute selon 3 critères, est-il possible de lui en ajouter une supplémentaire, à savoir colonne AG non vide valable pour les 4 onglets triés ?

Est il également possible lors de la copie du tableau dans les 4 onglets :
1. Appliquer un format particulier pour certaines colonnes (ex : jj/mm/aaaa ou encore ajouter aux chiffres le signe %)
2. Appliquer une hauteur de lignes pour le tableau de 18 centré verticalement en dehors des entêtes ?

Merci d'avance
Bon week-end
 
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Extraction de base sur nouveau fichier selon 3 critères

Bonjour Julie,

Ci joint un fichier sur le dernier modèle en ma possession.
Le critère a été ajouté (ajustement tableaux Cl et Flt, ligne supplémentaire dans exploration de la base). Les lignes nouvelles ou modifiées sont indiquées par NEW.
Le bloc format a été déplacé.
Le bloc tri a aussi été déplacé pour éviter une erreur si l'un des onglets n'a aucune ligne qui matche toutes les conditions).
Il y a un exemple de colonne au format % et un exemple au format jj/dd/mmmm.
Si il y a des trucs pas clairs n'hésite pas.

Cordialement

KD

Edit : Une erreur dans les déplacements, corrigé
 

Pièces jointes

  • Extract Base J31.zip
    22.1 KB · Affichages: 31
Dernière édition:
Vote positif 0 Vote négatif
Julie-F

Julie-F

XLDnaute Occasionnel
Re : Extraction de base sur nouveau fichier selon 3 critères

Merci beaucoup Kendev :)
Je vais regarder ton code et essayer de l'adapter à mon fichier. :eek:

J'ai des % un peu partout, idem pour les dates:(
Je te joins un fichier modifié.

Bon dimanche
 

Pièces jointes

  • Extract Base J4.zip
    21.1 KB · Affichages: 33
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

lajoie25
  • Question
XL 2016 Extraction de données selon critères
Réponses
2
Affichages
735
Robert
Robert
T
  • Question
Microsoft 365 Planning de réservation de matériel (avec gestion des stocks) - Formules utiles ?
Réponses
7
Affichages
2 K
vgendron
vgendron
J
  • Question
XL 2019 MFC sur des fichiers auto générés
Réponses
12
Affichages
721
jui42
J
M
  • Question
Microsoft 365 Extraction de données selon plusieurs critères
Réponses
6
Affichages
2 K
mutzik
mutzik
Q
  • Question
XL 2016 Extraction de données vers nouveau classeur selon critère
Réponses
6
Affichages
1 K
Qub
Q
D
  • Question
Microsoft 365 CREATION DE FICHIER DE SUIVI AUTOMATISE
Réponses
5
Affichages
3 K
desto
D
B
  • Question
XL 2013 [VBA] Extraction de données basé sur 2 à 3 conditions
Réponses
2
Affichages
2 K
bastienb
B
LAETI-TOINOU
  • Question
Microsoft 365 Tableau suivi de billeterie d'un CSE
2
Réponses
16
Affichages
4 K
LAETI-TOINOU
LAETI-TOINOU
L
  • Question
Base de donnée volontaires à répartir
Réponses
4
Affichages
1 K
Luke91
L
K
  • Question
XL 2010 Extraction de lignes d'un fichier texte selon un argument
Réponses
6
Affichages
1 K
micheldu52
micheldu52

Membres actuellement en ligne

1 membres et 36 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
312 105
Messages
2 085 350
Membres
102 870
dernier inscrit
Armisa