Sub Couleur_Extraction()
Dim F1 As Worksheet, F2 As Worksheet, code$
Dim Pnom%, Cgrade%, Lgrade%, P As Range, x$, lig&
Dim c As Range, dest As Range, dossier$, s, i%, y$, c1 As Range
'---données--
Set F1 = Feuil1 'CodeName
Set F2 = Feuil2 'CodeName
code = F1.[I1] 'à adapter
Pnom = 241 'position du nom
Cgrade = 2 'code devant le grade
Lgrade = 60 'longueur du grade
'---RAZ---
Application.ScreenUpdating = False
F1.[B:B].Interior.ColorIndex = xlNone
F2.Range("2:" & F2.Rows.Count).ClearContents
If code = "" Then Exit Sub
'---analyse---
Set P = F1.Range("B1", F1.Range("B" & F1.Rows.Count).End(xlUp))
x = "*" & code & "*" & code & "*"
lig = 1
For Each c In P
If c(1, 4) Like x Then 'en colonne E
lig = lig + 1
Set dest = F2.Cells(lig, 1)
dossier = c
dest = dossier
s = Split(c(1, 4), code)
For i = 1 To UBound(s)
y = Mid(s(i), 2)
If InStr(y, ",") Then 'longueur définie par la virgule
y = Left(y, InStr(y, ",") + 2)
ElseIf InStr(y, " ") Then 'longueur définie par 2 espaces
y = Left(y, InStr(y, " ") - 1)
End If
dest(, 3 + i) = y
Next
For Each c1 In P
If c1 = dossier Then
c1.Interior.ColorIndex = 6 'couleur jaune
If c1(1, 3) = 5 Then 'en colonne D
y = Mid(c1(1, 4), Pnom)
dest(, 2) = Application.Trim(Left(y, InStr(y, Cgrade) - 1))
dest(, 3) = Application.Trim(Mid(y, InStr(y, Cgrade) + 1, Lgrade))
End If
End If
Next
End If
Next
F2.Columns.AutoFit 'ajustement largeurs colonnes
End Sub