XL 2019 Comment extraire données soulignés excel?

[kevin.lvd]

Bonjour,

j'ai vu dans un ancien forum qu'il était possible d'extraire les données souligné d'une cellule avec cette macro

Sub Macro1()
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim c As String 'déclare la variable c (Caractère)
Dim m As String 'déclare la variable m (Mot)
Dim i As Integer 'déclare la variable i (Incrément)


With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1"
dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée dl de la colonne A
For Each cel In .Range("A2:A" & dl) 'boucle 1 : sur toutes les cellule éditées cel de la colonne A
m = "" 'réinitialise la variable m
For i = 1 To Len(cel.Value) 'boucle 2 : sur tos les caractères de la cellule cel
'si le caractère est souligné rajoute le caractère au mot m
If cel.Characters(Start:=i, Length:=1).Font.Underline = xlUnderlineStyleSingle Then m = m & Mid(cel.Value, i, 1)
Next i 'prochain caractère de la boucle 2
cel.Offset(0, 1).Value = m 'place le mot m dans la colonne B
Next cel 'prochaine cellule de la boucle 1
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

Mon problème c'est que dans une cellule, il y a plusieurs mots soulignés. Du coup lorsque que j'exécute la macro, je me retrouve bien avec les mots soulignés, mais ils ne sont pas séparés...

Est ce que vous auriez une idée de comment mettre cela en oeuvre ?

Merci par avance !

 

[Staple1600]

Re

En attendant une version allinone par tableau

Spoiler: Trois étapes pour faire le job et une macro que lance le traitement

Sub traitement()
Application.ScreenUpdating = False
extraction
nettoyage
finition
End Sub
Private Sub extraction()
Dim i&, c&
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For c = 1 To Len(Cells(i, 1))
        With Cells(i, 1).Characters(c, 1)
            If .Text = "," Then mot = mot & "|"
                If .Font.Underline = xlUnderlineStyleSingle Then
                mot = mot & Mid(Cells(i, 1).Value, c, 1)
            End If
            End With
        Next c
    Cells(i, 2).Value = mot
    mot = ""
Next i
End Sub
Private Sub nettoyage()
Dim vArr
vArr = Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))
Columns(2).TextToColumns _
                        Destination:=Range("C1"), DataType:=xlDelimited, _
                        Other:=True, OtherChar:="|", _
                        FieldInfo:=vArr
End Sub
Private Sub finition()
Dim i&, lr&
lr = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lr
Range("C" & i, "Z" & i).Sort _
        Key1:=Range("C" & i), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal
Next i
End Sub