Trier sur des bases de données avec conditions

  • Initiateur de la discussion Initiateur de la discussion ecosphere
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

E

ecosphere

Guest
Bonjour

J'ai cherché des solutions sur divers forum et dans celui ci mais je ne trouve pas la solution à mes 2 problèmes de tri de bases.

J'ai bricolé avec Recherche et BDLire et Index mais ça ne marche pas !!

Merci de votre aide.

Pour être plus clair le fichier Excel est joint !
 

Pièces jointes

Re : Trier sur des bases de données avec conditions

Bonjour ecosphère et bienvenu, bonjour le forum,

Est-ce qu'une solution VBA (par macro) pourrait te convenir ou tu ne souhaites qu'une solution par formule ?
 
Re : Trier sur des bases de données avec conditions

Bonjour ecosphère et bienvenu, bonjour le forum,

Est-ce qu'une solution VBA (par macro) pourrait te convenir ou tu ne souhaites qu'une solution par formule ?

Bonjour Robert

Merci de t'intéresser à mon sujet.
De préférence avec formule mais je suis preneur des 2 (formules et VBA), car je cherche une solution.
Par contre je sais activr une macro et l'enregistrer mais je ne connais pas le VBA.

Merci d'avance de tes conseils

Ecosphere
 
Re : Trier sur des bases de données avec conditions

Bonjour Écosphère, bonjour le forum,

En pièce jointe ton fichier modifier qu'il faudra certaiment adapter à tes fichiers originaux... Le code est commenté... Un bouton pour chaque action, Tri pour le problème 1 et Récup. pour le problème 2 :
Le code pour Tri :
Code:
Sub Macro1()
Dim o1 As Object 'déclare la variable o1
Dim o2 As Object 'déclare la variable o2
Dim dl As Integer 'déclare la variable dl
Dim pl As Range 'déclare la variable pl
Dim dest As Range 'déclare la variable dest (cellulke de DESTination)

Set o1 = Sheets("Feuil1") 'définit l'onglet o1
Set o2 = Sheets("Feuil2") 'définit l'onglet o2
Application.ScreenUpdating = False 'masque les changements à l'écran
o2.Cells.Clear ''effacement des anciennes données
dl = o1.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée de la colonne 1 (=A) de l'onglet o1
Set pl = o1.Range("A1:L" & dl) 'définit la plage pl
For x = 1 To 9 'boucle sur le 9 critères
    o1.Range("A1").AutoFilter 'filte automatique activé
    o1.Range("A1").AutoFilter field:=x + 3, Criteria1:="x" '1 filtre sur le critère (x)
    o1.Range("A1").AutoFilter field:=3, Criteria1:="OUI" 'second filtre sur le matériel (OUI)
    o1.Range("A1").AutoFilter field:=2, Criteria1:="x" 'troisième filtre sur présent dans l'entreprise (OUI)
    If pl.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then 'condition : si le nombre de lignes visibles de pl est supérieur à 2
        'définit la cellule de destination dest (A1, ai A1 est vide, sinon la seconde cellule vide rencontrée dans la colonne A de f2
        Set dest = IIf(o2.Range("A1").Value = "", o2.Range("A1"), o2.Cells(Application.Rows.Count, 1).End(xlUp).Offset(2, 0))
        pl.SpecialCells(xlCellTypeVisible).Copy dest 'copie la plage pl et la colle dans dest
        dest.Value = "LISTE des POSTE " & x 'Ajoute le critère à l étiquette
    End If 'fin de la condition
    o1.Range("B6").AutoFilter 'filtre automatique désactivé
Next x 'prochain critère de la boucle
Application.ScreenUpdating = False 'affiche les changements à l'écran
End Sub
Il te faudra adapter les noms des onglet et les colonnes des plages. Dans l'exemple le tableau commence en A1.

Le code pour le bouton Récup. :
Code:
Sub Macro2()
Dim tos(2) As Object 'déclare le tableau de deux variables to (Tableau des OngletS)
Dim pad As Range 'déclare la variable pad (Plage Anciennes Données)
Dim i As Byte 'déclare la variable i (Incrément)
Dim dl As Integer 'déclare la variable dl
Dim pl As Range 'déclare la variable pl
Dim cel As Range 'déclare la variable cel (CELlule)
Dim pli As Range 'déclare la variable pli (Plage de LIgne)
Dim dest As Range 'déclare la variable dest (cellulke de DESTination)

Set tos(0) = Sheets("VB01") 'définit la variable 0 du tableau tos
Set tos(1) = Sheets("HD01") 'définit la variable 1 du tableau tos
Set tos(2) = Sheets("Récup") 'définit la variabe 2 du tableau tos (tu adapteras à ton cas)
'effacement des anciennes données
If tos(2).Range("A2").Value <> "" Then 'condition : si la cellule A2 de l'onglet "Récup" n'est pas vide
    Set pad = tos(2).Range("A1").CurrentRegion 'définit la plage pad des anciennes données
    Set pad = pad.Offset(1, 0).Resize(pad.Rows.Count - 1, pad.Columns.Count) 'redoefinit la plage pad (sans la première ligne)
    pad.Clear 'supprime tout dans la plage pad
End If 'fin de la condition
'récupérations des nouvelles données
For i = 0 To 1 'boucle 1 : sur les deux premiers onglets
    With tos(i) 'prend en compte l'onglet de la boucle
        dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée de la colonne A (=1) de l'onglet BV01
        Set pl = .Range("A2:A" & dl) 'définit la plage pl
        For Each cel In pl 'boucle 2 : sur toutes les cellules cel de la plage pl
            Set pli = Application.Union(cel, cel.Offset(0, 1), cel.Offset(0, 3), cel.Offset(0, 5))
            Set dest = tos(2).Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0)
            pli.Copy dest
        Next cel
    End With
Next i
End Sub
Idem, à adapter...

Le fichier :
 

Pièces jointes

Re : Trier sur des bases de données avec conditions

Bonjour Robert

Merci de ce super code en VBA.
Ne connaissant pas je suis toujours impressionné et surtout par la démarche de réflexion qui permet d'écrire tout ça.
Comme je suis sur Smartphone je ne peux pas teste le code mais je le fais demain et je te tiens au courant bien sur.
Au fait c'est combien d'année de programmation VBA pour savoir ça ?

Encore Merci

Ecosphere.
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

Réponses
5
Affichages
306
Réponses
14
Affichages
884
Retour