1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
| Option Explicit
Sub Test()
Dim DerLig As Long
Dim Fournisseurs, Tablo(), k, i
Dim MaPlage As Range, Cel As Range, C As Range
Dim n As Integer
Dim firstAddress As String
'Les conformités sont inscrites dans un tableau suivant leur ordre de priorité
Tablo = Array("MD", "ILL", "LEG", "DUR", "CERT")
Set Fournisseurs = CreateObject("Scripting.Dictionary")
With Worksheets("Feuil1") 'Nom de feuille à adapter
'Recherche du numéro de la dernière ligne renseignée dans la colonne A
DerLig = .Range("A" & .Rows.Count).End(xlUp).Row
'Définition de la plage de données correspondant aux fournisseurs
Set MaPlage = .Range("A2:A" & DerLig)
' On passe en revue chaque cellule de cette plage
For Each Cel In MaPlage
'Si le fournisseur n'a pas déjà été inscrit dans le dictionnaire
If Not Fournisseurs.Exists(Cel.Value) Then
'On ajoute son nom ainsi que la conformité du site
Fournisseurs.Add Cel.Value, Cel.Offset(0, 2).Value
Else
'sinon, le fournisseur étant inscrit dans le dictionnaire, on compare la conformité inscrite à _
celle correspondant à la cellule scrutée.
'Si le numéro d'ordre de la conformité inscrite est supérieur à celui de la cellule scrutée, _
on remplace la conformité inscrite par celle de la cellule scrutée.
If Application.Match(Cel.Offset(0, 2), Tablo, 0) < Application.Match(Fournisseurs.Item(UCase(Trim(Cel))), Tablo, 0) Then
Fournisseurs.Item(UCase(Trim(Cel))) = Cel.Offset(0, 2)
End If
End If
Next Cel
'On dispose alors d'un dictionnaire renseigné avec le nom de chaque fournisseur et sa conformité prioritaire.
'On passe en revue chaque fournisseur du dictionnaire, on recherche les correspondances dans la colonne A _
et on note la conformité prioritaire correspondante.
k = Fournisseurs.keys
i = Fournisseurs.items
For n = 0 To Fournisseurs.Count - 1
Set C = MaPlage.Find(k(n), LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Address
Do
C.Offset(0, 3).Value = i(n)
Set C = MaPlage.FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
Set C = Nothing
End If
Next n
Set MaPlage = Nothing
End With
Set Fournisseurs = Nothing
End Sub |
Partager