XL 2010 extraire des mots en gras

carber

XLDnaute Nouveau
Bonjour j'ai un fichier qui me permet extraire des mots en gras le souci que je n'arrive pas a mettre chaque mot dans une cellule

par exemple dans une phrase j'ai deux mot en gras ou plus alors quand j’exécute le bouton il me colle les mot qui sont en gras je souhaite les mettre chaque mot dans une cellule

svp
cordialement
 

Pièces jointes

  • test-extraction-texte-en-gras.xlsm
    19.5 KB · Affichages: 12

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Carber,
Un essai avec :
VB:
Sub Test()
  Dim Plage As Range, Cel As Range
  Dim I%, Dl%, X%, Mot$
    Application.ScreenUpdating = False
    Dl = Range("A" & Rows.Count).End(xlUp).Row
    Set Plage = Range("A1:A" & Dl)
    Range("C2:ZZ" & Dl).ClearContents
    For Each Cel In Plage
        X = 2
        With Cel
            For I = 1 To Len(.Text)
                If .Characters(I, 1).Font.Bold = True Then
                    Mot = Mot + .Characters(I, 1).Text
                End If
                If Mid(Cel, I, 1) = " " And Mot <> "" Then
                    Cel.Offset(0, X) = Mot
                    Mot = "": X = X + 1
                End If
            Next I
        End With
    Next Cel
    Application.ScreenUpdating = True
End Sub
 

Pièces jointes

  • test-extraction-texte-en-gras (1).xlsm
    19.9 KB · Affichages: 8

sylvanu

XLDnaute Barbatruc
Supporter XLD
Je n'ai juste rajouté que :
VB:
If Mid(Cel, I, 1) = " " And Mot <> "" Then
   Cel.Offset(0, X) = Mot
   Mot = "": X = X + 1
End If
Ce n'est pas ce code qui ralentit la macro, elle était lente au départ.
Et ce n'était pas une demande initiale que de l'accélérer.
Combien de lignes avez vous au max ?
 

job75

XLDnaute Barbatruc
Bonjour carber, sylvanu,

Voyez le fichier joint et la fonction VBA entrée en colonne B :
VB:
Sub Entrer_Mots_Gras()
ActiveSheet.UsedRange.Columns(2) = "=Mots_Gras(RC[-1])"
End Sub

Function Mots_Gras$(c As Range)
Dim x$, s, i%, n%, a%()
x = " " & c
s = Split(x)
If UBound(s) = 0 Then Exit Function
'---positions des mots---
For i = 1 To Len(x) - 1
    If Mid(x, i, 1) = " " Then
        n = n + 1
        ReDim Preserve a(1 To n) 'base 1
        a(n) = i
    End If
Next
'--repérage des mots en gras---
For i = 1 To UBound(a)
    If c.Characters(a(i), 1).Font.Bold Then Mots_Gras = Mots_Gras & " " & s(i)
Next
Mots_Gras = Application.Trim(Mots_Gras)
End Function
Pour qu'un mot soit récupéré il suffit que son 1er caractère soit en gras.

Pour tester j'ai recopié le tableau A1:A20 sur 800 lignes, la macro s'exécute chez moi en 3 secondes.

A+
 

Pièces jointes

  • test-extraction-texte-en-gras(1).xlsm
    22.8 KB · Affichages: 15

patricktoulon

XLDnaute Barbatruc
re
Bonjour à tous
et si on pensait autrement juste pour le fun ;)

bien sur la fonction est utilisable directement en formule
ou dans une boucle en VBA si vous voulez


VB:
Sub testXML()
    MsgBox GetBolderWord([A2])
End Sub


Function GetBolderWord(cel As Range)
    Dim x$, z$, I&
    x = cel.Value(xlRangeValueXMLSpreadsheet)
    With CreateObject("htmlfile")
        .body.innerhtml = x
        Set mots = .getelementsbytagname("B")
        For I = 0 To mots.Length - 1: z = z & mots(I).innertext & " ": Next
    End With
    GetBolderWord = Trim(z)
End Function
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Carber, Job, Patricktoulon,
Pour répondre à Carber en séparant les mots ( un par colonne ) et en accélérant le processus, je suis reparti de la macro de Job, rapide, à laquelle j'ai adjoint une macro de séparation.
Sur 800 lignes, et sur mon PC, je passe de 7.2s pour la structure initiale, à 1.5s avec la pièce jointe.
 

Pièces jointes

  • test-extraction-texte-en-gras(V3).xlsm
    36.4 KB · Affichages: 5

job75

XLDnaute Barbatruc
En fait dans la fonction du post #6 la variable tableau a() est inutile, ceci va bien :
VB:
Function Mots_Gras$(c As Range)
Dim x$, s, i%, n%
x = " " & c
s = Split(x)
If UBound(s) = 0 Then Exit Function
For i = 1 To Len(x) - 1
    If Mid(x, i, 1) = " " Then
        n = n + 1
        If c.Characters(i + 1, 1).Font.Bold Then Mots_Gras = Trim(Mots_Gras & " " & s(n))
    End If
Next
End Function
Fichier (2) de 800 lignes avec la commande Convertir , l'exécution prend un peu moins de 3 secondes.
 

Pièces jointes

  • test-extraction-texte-en-gras(2).xlsm
    29.3 KB · Affichages: 6

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
@job75 perso je pige pas moins de 3 secondes tu dis ?
fichier du post#12
1632569786994.png
 

patricktoulon

XLDnaute Barbatruc
re
et voila la démo en html en version range globale valueXML
toujours sur le même fichier (post#12) ,elle est plus que parlante ;)

je vous laisse découvrir le temps que ça mettra chez vous
bien que l'on en a une petite idée dans la capture animée 🤣
VB:
Sub testXML()
    Dim Tbl, T#, RnG As Range
    T = Timer
    With [b1]
        .Resize(Rows.Count, 50).ClearContents
        Tbl = GetBolderWord([A1].CurrentRegion)
        .Resize(UBound(Tbl) + 1, 50).Value = Tbl
    End With
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec")
End Sub


Function GetBolderWord(cel As Range)
    Dim x$, I&, Tbl(), p&, a&, q&
    ReDim Tbl(cel.Count, 50)
    x = cel.Value(xlRangeValueXMLSpreadsheet)
    With CreateObject("htmlfile")
        .body.innerhtml = x
        Set celhtml = .getelementsbytagname("Cell")
        For I = 0 To celhtml.Length - 1
            Set chainebolds = celhtml(I).getelementsbytagname("B")
            p = 0
            For a = 0 To chainebolds.Length - 1
                mots = Split(chainebolds(a).innertext)
                For q = 0 To UBound(mots)
                    Tbl(I, p) = mots(q)
                    p = p + 1
                Next
            Next
        Next
    End With
    GetBolderWord = Tbl
End Function

si vous en doutez je met le fichier joint
demo7.gif
 

Pièces jointes

  • test-extraction-texte-en-gras html version 2 patricktoulon .xlsm
    34.8 KB · Affichages: 14

Discussions similaires

Statistiques des forums

Discussions
311 737
Messages
2 082 030
Membres
101 876
dernier inscrit
JULIEN21370