Sub Polobe36()
Dim DerLig1 As Long, DerLig2 As Long, DerCol As Byte
Dim WS1 As Worksheet, WS2 As Worksheet
Dim MonDico, Tableau, i, c, montab, art, TabFin
Dim MaConcat As String, MaClé As String, EtatDefaut As String
Dim Deb, Fin
Deb = Timer()
Set WS1 = Worksheets("Catalogue")
Set WS2 = Worksheets("Règles")
DerLig1 = WS1.Range("A" & Rows.Count).End(xlUp).Row
Set MonDico = CreateObject("Scripting.Dictionary")
DerLig2 = WS2.Range("A" & Rows.Count).End(xlUp).Row
Tableau = WS2.Range("A4:A" & DerLig2)
For i = LBound(Tableau) To UBound(Tableau)
DerCol = WS2.Cells(i + 3, Columns.Count).End(xlToLeft).Column
montab = WS2.Range(WS2.Cells(i + 3, 2), WS2.Cells(i + 3, DerCol))
MonDico.Item(Tableau(i, 1)) = montab
Next i
TabFin = WS1.Range("Y4:Z" & DerLig1)
For i = LBound(TabFin) To UBound(TabFin)
MaClé = TabFin(i, 2)
If MonDico.exists(MaClé) Then
MaConcat = MaClé & " "
For Each art In MonDico.Item(MaClé)
If IsNumeric(art) Then MaConcat = MaConcat & WS1.Cells(i + 3, 26 + art)
If Not IsNumeric(art) Then MaConcat = MaConcat & art
Next
TabFin(i, 1) = MaConcat
Else
EtatDefaut = EtatDefaut & "DEFAUT REGLE " & TabFin(i, 2) & Chr(10)
TabFin(i, 1) = "DEFAUT de REGLE : " & TabFin(i, 2)
End If
MaConcat = ""
Next i
WS1.Range("Y4").Resize(UBound(TabFin, 1)) = Application.Index(TabFin, , 1)
Fin = Timer()
EtatDefaut = EtatDefaut & "Traitement réalisé en : " & Fin - Deb & " secondes"
MsgBox EtatDefaut
End Sub