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

kevin.lvd

XLDnaute Nouveau
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 !
 
Solution
@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

XLDnaute Impliqué
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
 

kevin.lvd

XLDnaute Nouveau
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
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

XLDnaute Nouveau
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
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

XLDnaute Barbatruc
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
 

kevin.lvd

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

Pièces jointes

  • Texte soulignié.xls
    37 KB · Affichages: 1

Staple1600

XLDnaute Barbatruc
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
 

kevin.lvd

XLDnaute Nouveau
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
Merci pour ta réponse. Oui en effet ca revient au même... Merci quand même !
 

Staple1600

XLDnaute Barbatruc
Re

Une fois l'extraction faite, un peu de ménage ;)
VB:
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

XLDnaute Impliqué
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)
VB:
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

==>
1611610842797.png


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

@Phil69970
 

kevin.lvd

XLDnaute Nouveau
@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

XLDnaute Impliqué
@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
 

Discussions similaires

Haut Bas