1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
| Sub Extraire()
Dim DerLig As Long, L As Long, Cpt As Long, i As Long
Dim Parenth_Ouv As Long, Parenth_Fer As Long
Dim Ph As String, Var As String
Dim Ext As Variant
Application.ScreenUpdating = False
DerLig = Range("A" & Rows.Count).End(xlUp).Row
If DerLig > 1 Then
Range(Cells(2, "C"), Cells(DerLig, "C")).ClearContents
For L = 2 To DerLig
Ph = Cells(L, "B").Value
Cells(L, "C").Value = Ph
Ext = Split(Ph, " " & Cells(L, "A") & " ") 'Extraction du mot
ReDim Isol(0) As String
For i = 1 To UBound(Ext)
Isol(Cpt) = "(" & Ext(i) & " " 'Ajout de la parenthèse ouvrante
Cpt = Cpt + 1
ReDim Preserve Isol(Cpt)
Next
'supprime le caractère spécifique dans la phrase
Cells(L, "C").Replace What:=" " & Cells(L, "A") & " ", Replacement:=""
'Affiche les mots à conserver entre parenthèses
For i = 0 To Cpt - 1
Cells(L, "C").Replace What:=Ext(i + 1), Replacement:=" " & Isol(i)
Next i
'Ajout de la parenthèse fermante
Parenth_Ouv = 1
For i = 0 To Cpt - 1
Parenth_Ouv = InStr(Parenth_Ouv, Cells(L, "C"), "(", 1)
Parenth_Fer = InStr(Parenth_Ouv, Cells(L, "C"), " ", 1) - 1
Var = Left(Cells(L, "C"), Parenth_Fer - 1) & Mid(Cells(L, "C"), Parenth_Fer, 1) & ") " & Mid(Cells(L, "C"), Parenth_Fer + 1, Len(Cells(L, "C")) - Parenth_Fer)
Cells(L, "C").Value = Var
Parenth_Ouv = Parenth_Fer + 1
Next
Cpt = 0
Next L
End If
End Sub |
Partager