Sub Julien()
'***** http://excel-downloads.com/threads/optimisation-forumle-ou-macro.20010202/*****
'***** 26/07/2016
'*****
Dim WS1 As Worksheet, WS2 As Worksheet, Dico1, Dico2, TabTmp(1 To 2)
Dim Code As String, i As Long, Clé
Dim TabVerif, Clair As String
Set WS1 = Worksheets("Histo")
Set WS2 = Worksheets("OK")
Set Dico1 = CreateObject("Scripting.Dictionary")
Set Dico2 = CreateObject("Scripting.Dictionary")
'************** colonne W
'**creation dico des codes
Tablo = WS2.Range("A5:E" & WS2.Range("A" & Rows.Count).End(xlUp).Row)
For i = LBound(Tablo) To UBound(Tablo)
TabTmp(1) = Tablo(i, 4)
TabTmp(2) = Tablo(i, 5)
Dico2(CStr(Tablo(i, 1))) = TabTmp
Next
Tablo = WS1.Range("F3:W" & WS1.Range("F" & Rows.Count).End(xlUp).Row)
'**mise à jour de la colonne W dans le tablo histo
For i = LBound(Tablo) To UBound(Tablo)
Code = CStr(Tablo(i, 8))
If Not Dico2.Exists(Code) Then
Tablo(i, 18) = "non"
'WS1.Cells(i + 2, 23) = "non"
ElseIf Dico2(Code)(2) = "x" Then
Tablo(i, 18) = "Pas suffisant"
'WS1.Cells(i + 2, 23) = "Pas suffisant"
Else
Tablo(i, 18) = Dico2(Code)(1)
'WS1.Cells(i + 2, 23) = Dico1(Code)(1)
End If
Next
'************** colonne X
'* creation dico nombre de oui,pas suffisant, <> oui
For i = LBound(Tablo) To UBound(Tablo)
Matric = CStr(Tablo(i, 1))
If Not Dico1.Exists(Matric) Then Dico1(Matric) = Array(0, 0, 0)
If Tablo(i, 15) = "NON" Then
If Tablo(i, 10) >= CDate("01/01/2014") Then
TabVerif = Dico1.Item(Matric)
If Tablo(i, 18) = "oui" Then
TabVerif(0) = TabVerif(0) + 1
ElseIf Tablo(i, 18) = "Pas suffisant" Then
TabVerif(1) = TabVerif(1) + 1
ElseIf Tablo(i, 18) <> "oui" Then
TabVerif(2) = TabVerif(2) + 1
End If
Dico1(Matric) = TabVerif
End If
End If
Next
' traduction des nombres en clair
For Each Clé In Dico1
If Dico1(Clé)(0) > 0 Then Clair = "Ok depuis le 01/01/2014"
If Dico1(Clé)(1) > 0 Then Clair = "Uniquement"
If Dico1(Clé)(2) > 0 Then Clair = "En risque"
If Dico1(Clé)(0) = 0 And Dico1(Clé)(1) = 0 And Dico1(Clé)(2) = 0 Then Clair = "NON"
Dico1(Clé) = Clair
Next
'******** préparation et copie du Tableau final colonne W et X
ReDim TabFin(1 To UBound(Tablo), 1 To 2)
For i = LBound(Tablo) To UBound(Tablo)
TabFin(i, 1) = Tablo(i, 18)
TabFin(i, 2) = Dico1(CStr(Tablo(i, 1)))
Next
WS1.Range("W3").Resize(UBound(TabFin, 1), 2) = TabFin
End Sub