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

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @patricktoulon :)
et ben dis donc je t'aurais attendu toi t'en a mis du temps
Je suis beaucoup moins présent sur XLD depuis quelques temps. J'ai vu par hasard que ça "frétillait" sur ce fil, j'ai donc un peu codé pour ne pas trop perdre la main.

22.68 secondes pour le model de @mapomme
Tu utilises un Amstrad ou un Commodore ? De quelle année ?
Résultats très étranges.

et "bonne humeur" sont deux mots
J'ai bien précisé que c'est une variante. Dans l'exemple du demandeur, les mots en gras semblent être des états ou des sentiments.
"Bonne" n'en est pas un, "humeur" non plus mais "bonne humeur" l'est... Et je le suis 😊
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
ben non j'utilise un pc normal
j'ai essayé ca aussi mais je met encore plus de 22 secondes
VB:
Sub Entrer_Mots_Gras()
    Dim T, cel As Range, tb
    T = Timer
    Application.ScreenUpdating = False
    [B1].Resize(Rows.Count, 6).ClearContents
    With ActiveSheet.UsedRange
        For Each cel In .Cells
            tb = Mots_Gras(cel)
            cel.Offset(, 1).Resize(, UBound(tb)) = tb
        Next
    End With
    MsgBox "Durée " & Format(Timer - T, "0.00 \sec")
End Sub
Sub testInstrdoloop()
     Mots_Gras$ ([A3])
End Sub
Function Mots_Gras(c As Range)
    Dim x$, s, I%, n%, pos&, z&, s2
    x = c.Value & " "
    s = Split(x)
     ReDim s2(1 To UBound(s))
    If UBound(s) = 0 Then Exit Function
    pos = 1
    For I = 0 To UBound(s)
        z = InStr(pos, c.Value, s(I))
         If c.Characters(z, 1).Font.Bold = True Then n = n + 1: s2(n) = s(I):
        pos = pos + Len(s(I))
    Next
     Mots_Gras = s2
End Function
 

patricktoulon

XLDnaute Barbatruc
pour vous donner une idée de mon etonnement je viens de tester un tableau global en restitution globale
c'est a dire que la fonction renvoie le tableau de toutes les ligne d'un coup
et surprise c'est kif kif a 1 seconde près j'ai le même temps 23,xx secondes
autrement sur mon install je travaille casiment a la meme vitesse avec un range qu'avec une variable tableau

j'avoue je suis décontenancé et agacé

si vous voulez bien tester
VB:
Option Explicit

Sub Entrer_Mots_Gras()
    Dim T, tb, Rng As Range
    T = Timer
    [B1].Resize(Rows.Count, 150).ClearContents
    Set Rng = ActiveSheet.UsedRange
    tb = Mots_Gras(Rng)
    Rng.Offset(, 1).Resize(, UBound(tb)) = tb


    MsgBox "Durée " & Format(Timer - T, "0.00 \sec")
End Sub


Function Mots_Gras(Rng As Range)
    Dim x, I%, n%, pos&, z&, a&, tbl2
    ReDim tbl2(1 To Rng.Rows.Count, 20)
    For I = 1 To UBound(tbl2)
        x = Split(Rng.Cells(I, 1).Value)
        pos = 1
        n = 0
        For a = 0 To UBound(x)
            z = InStr(pos, Rng.Cells(I, 1), x(a))
            If Rng.Cells(I, 1).Characters(z, 1).Font.Bold = True Then n = n + 1: tbl2(I, n) = x(a)
            pos = pos + Len(x(a))
        Next
    Next
    Mots_Gras = tbl2
End Function
je vais faire un dernier test (je soupconne un truc ) et déjà remarqué et je reviens
 

patricktoulon

XLDnaute Barbatruc
Bon ben c'est choux blanc
j'ai cru que comme souvent quand je télécharge un fichier 2016 zt plus
et donc plus le core xml étant plus lourd ça me joue des tours sur la rapidité mais là non pas moyen de passer en dessous les 22/23 secondes

ça peut pas être le pc si je met moins d'une seconde en html
j'ai supprimer le kb pour le LAAC
j'ai supprimé le complément PowerQuery
mon excel est vierge
j'avoue je suis perdu
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Re @patricktoulon,

Test de ton code du post #30 sur le fichier du post #14 : 3,5 s.

Je suppose que tu as éteint le PC puis redémarrer (un jour ça m'a supprimé des incohérences dans les traitements d'Excel). Mais là je doute fort que cela améliore les choses.
Tu n'as pas une autre machine pour tester?

C'est tout de même fort de café ton anomalie et pas facile pour trouver une piste!
 
Dernière édition:

carber

XLDnaute Nouveau
Bonsoir
Je vous remercie pour l'aide que vous nous apporté

je souhaite mettre tout les mots qui sont récupérer dans une autre feuille et dans une seul colonne

j'ai mis dans le code

VB:
Range("C2:C400").Copy Feuil2.Range("A1:A400")
Range("D2:D400").Copy Feuil2.Range("B1:B400")
Range("E2:E400").Copy Feuil2.Range("C1:C400")

mais je ne arrive pas a fusionner en une seule liste de mot

- A la place que les mots en gras s'affiche dans le feuille 1 a coté le texte, je souhaite affiché les mot dans la feuille 2 en une seule liste et une seule colonne
 

Pièces jointes

  • extractiontexte-en-gras- v1.xlsm
    74.3 KB · Affichages: 3

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG