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

Phil69970 à dit:

Bonjour Kevin, le forum

Une piste :

VB:

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("Feuil2") '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 tous les caractères de la cellule cel
            'si le caractère est souligné rajoute le caractère au mot m
           
            '------------Recherche les espaces ----------
            If Mid(cel.Value, i, 1) = " " Then m = m & "    "   '<== ici on peut mettre des tirets par exemples
            '------------Fin de recherche des espaces ----------
           
            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
        m = m & "      " & m
    Next cel 'prochaine cellule de la boucle 1
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

@Phil69970

Cliquez pour agrandir...

Phil69970 à dit:

Bonjour Kevin, le forum

Une piste :

VB:

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("Feuil2") '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 tous les caractères de la cellule cel
            'si le caractère est souligné rajoute le caractère au mot m
           
            '------------Recherche les espaces ----------
            If Mid(cel.Value, i, 1) = " " Then m = m & "    "   '<== ici on peut mettre des tirets par exemples
            '------------Fin de recherche des espaces ----------
           
            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
        m = m & "      " & m
    Next cel 'prochaine cellule de la boucle 1
End With 'fin de la prise en compte de l'onglet "Feuil1"
End Sub

@Phil69970

Cliquez pour agrandir...

Staple1600 à dit:

Bonsoir le fil

=>kevin.lvd
Est-ce tu pourrais joindre une version allégée et anonymisée de ton fichier?
Car il y a peut-être un autre critère que le soulignement qui permettrait une mise en œuvre plus simple de ton extraction.

Cliquez pour agrandir...

Staple1600 à dit:

Re

Il faudrait des données plus proches de la réalité, car dans ton exemple, les valeurs sont doublonnées
Néanmoins, selon ce que sont les vrais données, je partirai déjà sur ceci.

VB:

Sub Test()
Columns(1).TextToColumns Destination:=Range("B1"), _
            DataType:=xlDelimited, Comma:=True, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1))
End Sub

Cliquez pour agrandir...

Staple1600 à dit:

Re

Plus ou moins la même piste que Phil69970
(avec plus ou moins les mêmes désagréments )

VB:

Sub test_Souligné()
Dim i&, c&
Application.ScreenUpdating = False
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

Cliquez pour agrandir...