Extraire selon critères

bonjour,

Alors là la demande est difficile

en feuil 1 colonne A choisir la rubrique ayant le plus petit tonnage associé (dans la base Feuil 2 colonne) et mettre cette rubrique en colonne B (en rouge ci dessous).

En feuil 1 colonne C D et E coller les bonnes rubriques d'après la colonne A avec comme critères si elles sont dans la la base de données feuil 2 et qu'elles ont une croix dans le seuil concerné.

exemple:

en espérant être clair.

merci d'avance

Bonjour

Ci joint ma solution

A+ François

bonjour,

1436 n'a pas de tonnage en feuil2 et certains rubriques qui ont tonnage="" ne sont pas considérés.

Sub yoga()
     Dim aA, aB, aC, aD, SCA, aTon(1 To 2)

     Set SCA = CreateObject("system.collections.arraylist")

     With Sheets("Feuil2").UsedRange
          aA = .Columns("A").Value2 'premiere colonne Feuil2
          aB = .Resize(, 6).Value2 'les 6 colonnes de Feuil2
     End With

     With Sheets("Feuil1")
          aC = .Range("A4:A" & .Range("A" & Rows.Count).End(xlUp).Row).Value2 'colonne A de feuil1
          ReDim aD(1 To UBound(aC), 1 To 4) 'preparer matrice
          For i = 1 To UBound(aC)
               If Len(aC(i, 1)) > 0 Then
                    sp = Split(aC(i, 1), ";") 'divisé sur ";"
                    SCA.Clear 'RAZ
                    aTon(1) = "NC": aTon(2) = 1000000000# 'tonnage exagéré, rubrique NC
                    For j = 0 To UBound(sp) 'boucle les éléments
                         r = Application.Match(--sp(j), aA, 0) 'rechercher comme numeriqie
                         If Not IsNumeric(r) Then r = Application.Match(sp(j), aA, 0) 'rchercher comme string
                         If IsNumeric(r) Then 'trouvé
                              If Len(aB(r, 3)) > 0 Then 'tonnage connu
                                   If aB(r, 3) < aTon(2) Then aTon(1) = sp(j): aTon(2) = aB(r, 3) 'tonnage inférieur au tonnage minimal jusqu'à maintenant
                              End If
                              If StrComp(aB(r, 4), "x") = 0 Then aD(i, 2) = IIf(Len(aD(i, 2)) = 0, "", ";") & sp(j) 'ajouter si marqué "X"
                              If StrComp(aB(r, 5), "x") = 0 Then aD(i, 3) = IIf(Len(aD(i, 3)) = 0, "", ";") & sp(j)
                              If StrComp(aB(r, 6), "x") = 0 Then aD(i, 4) = IIf(Len(aD(i, 4)) = 0, "", ";") & sp(j)
                         End If
                    Next
                    aD(i, 1) = aTon(1)
                    For j = 1 To UBound(aD, 2)
                         If aD(i, j) = "" Then aD(i, j) = "NC"
                    Next
               End If
          Next
     End With

     Sheets("feuil1").Range("B4").Resize(UBound(aD), UBound(aD, 2)).Value = aD

End Sub

Merci à vous 2, les solutions me paraissent intéressantes !

- la proposition de Fanfan à l'air de bien fonctionner.

-la proposition de BsAlv à l'air prometteuse mais j'ai un "erreur automation" pour system.collections.arraylist.

Je pense que c'est un problème de version excel ou bien il faut remplacer par Dictionary ?

J'aimerai bien tester.

bonjour, le SCA n'était plus nécessaire, c'était dans une solution précédente ... . Les 2 solutions avec un raccourci CTRL+SHIFT+C pour "compèter" et CTRL+SHIFT+Y pour "Yoda" et les différences en forme conditionelles. Pour ma macro un "x" ou "X" est égal (majuscule/miniscule)

Parfait , merci pour tout !

effectivement en observant mieux c'est la macro yoga qui à toutes les valeurs voulues.

merci à vous 2