Sub extract()
'mise tableau des titres de la feuille 2
tablo = Sheets("Feuil2").Range("C1:F1")
'Effacement des resultats precedents (peut etre supprimée si plusieurs transferts successifs a effectuer)
Sheets("Feuil2").Range("A2:F" & Rows.Count).ClearContents
'pour chaque cellule de la colonne C de la feuille 1 a partir de la ligne 2
For n = 2 To Range("C" & Rows.Count).End(xlUp).Row
'chercher la derniere ligne vide de la feuille2 colonne A
derlin = Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row + 1
'inscrire en colonne A et B feuille 2 les noms et prenoms
Sheets("Feuil2").Range("A" & n) = Sheets("Feuil1").Range("A" & n)
Sheets("Feuil2").Range("B" & n) = Sheets("Feuil1").Range("B" & n)
' Mettre sous forme de tableau le contenu de la cellule (decoupage a chaque retour chariot
x = Split(Range("C" & n), Chr(10))
' pour chaque element de ce tableau
For m = LBound(x) To UBound(x)
'chercher dans le tableau des titres si l'un d'eux est present
For p = LBound(tablo, 2) To UBound(tablo, 2)
If InStr(x(m), tablo(1, p)) <> 0 Then
'si oui chercher ou se situe le :
Z = InStr(x(m), ":")
'inscrire en feuille 2 le contenu situé apres le :
Sheets("Feuil2").Cells(derlin, p + 2) = Mid(x(m), Z + 1)
End If
Next
Next
Next
'presenter la feuille 2
Sheets("Feuil2").Select
End Sub