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 !

 

[Phil69970]

Bonjour Kevin, le forum

Une piste :

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

 

[kevin.lvd]

Bonjour Kevin, le forum

Une piste :

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

Tout d'abord merci pour votre réponse cela est en effet beaucoup mieux ! Je n'ai plus qu'à utilisé quelques formules pour avoir ce que je veux mais le principale est fait. Merci beaucoup !!!!!

 

[kevin.lvd]

Bonjour Kevin, le forum

Une piste :

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

Je ne suis pas très doué en macro excel... et tout compte fait, je reçoit cela grâce à votre code
,,,,,,,M.Dupont,,,,,M.Durant
,,M.Lemercier,,,K.Jason

Du coup je ne voit pas trop comment supprimer toutes les virgule sauf une qui séparera mes deux personnes..

 

[Staple1600]

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.

 

[kevin.lvd]

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.

Merci pour votre réponse. Voici un exemple

 

[Staple1600]

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.

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

 

[kevin.lvd]

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.

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

Merci pour ta réponse.

Ta macro fonctionne très bien pour repartir chaque virgule dans une colonne. Or je ne peut pas identifier les nom qui étaient souligner. De base mon fichier fais 1400 lignes...

 

[Staple1600]

Re

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

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

 

[kevin.lvd]

Re

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

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

Merci pour ta réponse. Oui en effet ca revient au même... Merci quand même !

 

[Staple1600]

Re

Une fois l'extraction faite, un peu de ménage

Sub Test_2()
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

 

[Phil69970]

Le fil

Une idée :

Si en A2 j'ai la phrase :

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...

J'ai en B2 tous les mots soulignés (ne marche que pour cette phrase)

Sub Convertir()
Range("B2").Select
Selection.TextToColumns Destination:=Range("B2"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(15, 1), Array(23, 1), Array(32, 1), Array(40, 1), _
    Array(87, 1), Array(131, 1), Array(140, 1)), TrailingMinusNumbers:=True
Columns("B:I").EntireColumn.AutoFit
End Sub

==>

Et tous les mots sont séparés....dans une cellule unique !

@Phil69970

 

[Staple1600]

Bonsoir Phil69970

J'ai pas compris ta manip.
Tu peux réexpliquer, stp?

 

[kevin.lvd]

@Phil69970 et @Staple1600 Merci beaucoup pour le temps que vous avez consacré à ce problème.

J'ai l'honneur de vous annoncer que cela fonctionne. J'ai utilisé la première macro Test_Souligné. Cela ma donc sortie toutes les personnes soulignées avec plusieurs "|".

J'ai ensuite utilisé la deuxième macro Test_2, qui a permis de dispatcher les différentes personnes dans plusieurs colonnes. Ensuite j'ai sélectionné toutes les cellules vides et je les ai supprimer. Ce qui me donne exactement ce que je voulais. Merci encore !!!!

 

[Phil69970]

@Staple1600

Mon idée (mais peut être pas très bonne) c'était d’exécuter la macro du post #2 puis de convertir les valeurs de la cellule B2 (en clair les mots soulignés) en éclatant les données en X cellules. (c'est ce que faisait la macro post #12 à adapter avec des variables adéquate (Pas de mon niveau) , ou bien plus simplement avec le bouton convertir ....
Edit...
C'est ce que doit faire ta macro post #11 que je viens de voir....

@Phil69970