Salut Sabrineagh,
voilà ton fichier que, accessoirement, je m'en rends compte maintenant, j'avais programmé comme un âne...
Enfin...
- même principe, tu double-cliques n'importe où dans la colonne affichant 'Libelle ecriture' ou tu y opères un changement quelconque ;
- la macro se charge de tout : repérage de la bonne colonne 'Libelle ecriture' et, évidemment, de la colonne 'Extract'.
Tu devrais remarquer une belle différence de vitesse de traitement avec la (très mauvaise) version précédente!
Public Sub Extraction(ByVal sCol1 As String, sCol2 As String)
'
Dim tData, tSplit, tExtract()
Dim iRow%, iIdx%, sData As String
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
tData = Range(sCol1 & "2:" & sCol1 & Range(sCol1 & Rows.Count).End(xlUp).Row).Value
Range(sCol2 & "2:" & sCol2 & Range(sCol2 & Rows.Count).End(xlUp).Row).ClearContents
For iRow = 1 To UBound(tData, 1)
sData = CStr(tData(iRow, 1))
tSplit = Split(CStr(tData(iRow, 1)), " ")
iIdx = iIdx + 1
ReDim Preserve tExtract(iIdx)
tExtract(iIdx - 1) = fctExtraire(tSplit, sData)
Next
Range(sCol2 & 2).Resize(iIdx, 1) = WorksheetFunction.Transpose(tExtract)
Columns(sCol2 & ":" & sCol2).AutoFit
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub
Public Function fctExtraire(tSplit, sData As String)
'
For x = 0 To UBound(tSplit)
If Len(tSplit(x)) > 1 Then
If Asc(Mid(tSplit(x), 2, 1)) > 64 And Asc(Mid(tSplit(x), 2, 1)) < 91 Then _
sMsg = sMsg & IIf(sMsg = "", tSplit(x), Chr(32) & tSplit(x))
End If
Next
fctExtraire = IIf(sMsg = "", sData, sMsg)
'
End Function
A+