XL 2010 extraire des mots en gras

[carber]

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

 

[sylvanu]

Bonjour Carber,
Un essai avec :

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

 

[carber]

Merci le souci ça prend trot de temps a exécuté la macro des fois j'ai un fichier pleins de texte

 

[sylvanu]

Je n'ai juste rajouté que :

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 ?

 

[carber]

ça peut aller jusqu’à 800 ligne c'est selon le texte que je colle après c'est pas grave je vais faire avec
merci pour t'on aide comme toujours présent

 

[job75]

Bonjour carber, sylvanu,

Voyez le fichier joint et la fonction VBA entrée en colonne B :

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+

 

[sylvanu]

Bonsoir Carber, Job,
@job, Il n'y a pas la séparation des mots comme demandé :

je souhaite les mettre chaque mot dans une cellule

 

[job75]

@job, Il n'y a pas la séparation des mots comme demandé :

Non car cela est sans intérêt mais il suffit d'utiliser la commande Convertir.

 

[patricktoulon]

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

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]

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.

 

[job75]

Bonjour carber, sylvanu, patricktoulon,

Sur 800 lignes la macro de patricktoulon s'exécute chez moi en 17 secondes.

En s'arrangeant pour que CreateObject("htmlfile") ne soit exécutée qu'une fois => 11 secondes.

A+

 

[job75]

En fait dans la fonction du post #6 la variable tableau a() est inutile, ceci va bien :

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.

 

[patricktoulon]

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

 

[patricktoulon]

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

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

 

[sylvanu]

Re,
C'est pour le moins excellent. Voilà qui va clore le débat.