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

patricktoulon

XLDnaute Barbatruc
re
non pas moyen
mon dernier code sur le fichier du post30
j'avoue que ca commence a me les chauffer ce truc
1632590006087.png
 

job75

XLDnaute Barbatruc
Bonsoir carber,

Il est temps de vous manifester !

Je ne vois pas l'intérêt d'utiliser une 2ème feuille mais bon.

Voyez ce fichier (3) et la macro dans le code de la feuille "Résultat" :
VB:
Private Sub Worksheet_Activate()
With Feuil1.UsedRange 'CodeName de la feuille à adapter
    With .Columns(2) 'colonne auxiliaire
        .FormulaR1C1 = "=Mots_Gras(RC[-1])"
        .Value = .Value 'supprime les formules
        .Cells(1) = "MOTS GRAS"
        [A1].Resize(.Rows.Count) = .Value 'copie les valeurs
        [A1].Offset(.Rows.Count).Resize(Rows.Count - .Rows.Count).ClearContents 'RAZ en dessous
        .ClearContents 'RAZ
    End With
End With
Columns(1).AutoFit 'ajustement largeur
End Sub
Elle se déclenche automatiquement quand on active la feuille.

La fonction VBA Mots_Gras est la même qu'au post #12.

A+
 

Pièces jointes

  • test-extraction-texte-en-gras(3).xlsm
    24.8 KB · Affichages: 4

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

Discussions similaires

Statistiques des forums

Discussions
311 730
Messages
2 081 978
Membres
101 854
dernier inscrit
micmag26