Macro Extraction et comptage de mot

magnusyou · 5 Mars 2015

Bonjour à tous,

Je rencontre un petit souci avec une macro qui me permet déjà d'extraire tous les mots d'une colonne et de me les compter.

En gros, si en colonne A j'ai :

voiture pas cher
voiture 206
peugeot 206 voiture

la macro me donne cela:

voiture --> 3 (car présent 3 fois au total)
206 --> 2
pas --> 1
cher --> 1
peugeot --> 1

Et c'est exactement ce que je souhaite!

Cela fonctionne avec ceci:

Sub Découpe()
Dim Mot As String, Phrase As String
Dim FinB As Long, FinC As Long
Dim Tourne As Long, Espace As Long, Trouve As Long
Dim Cherche As Range
FinB = Range("B" & Rows.Count).End(xlUp).Row
For Tourne = 3 To FinB
Phrase = Range("b" & Tourne) & " "
Espace = 0
Trouve = 1
Do
Trouve = InStr(Trouve, Phrase, " ") + 1
Mot = LCase(Split(Phrase, " ")(Espace))
Set Cherche = Range("C:C").Find(Mot, lookat:=xlWhole)
If Cherche Is Nothing Then
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = LCase(Mot)
Range("D" & Range("C" & Rows.Count).End(xlUp).Row) = 1
Else
Range("C" & Cherche.Row) = LCase(Mot)
Range("D" & Cherche.Row) = Range("D" & Cherche.Row) + 1
End If
Espace = Espace + 1
Loop Until InStr(Trouve, Phrase, " ") = 0
Next Tourne
End Sub

Le problème actuel c'est que j'ai un fichier très lourd (350K lignes) et que la macro bug à un moment donné..

et je ne comprends pas l'erreur.. Je pensais que c'était à cause de certains caractères spéciaux mais non..

Voici le fichier en question --> https://www.dropbox.com/s/pvs4z4dqsz34b9j/Maison.xlsx?dl=0

Est-ce que quelqu'un pourrait me dire comment faire fonctionner cette macro sur mon fichier svp?

Merci à tous,

magnusyou

Paf · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Bonjour

un certain nombre de données en colonne B ( une quinzaine sur 65535 lignes (XL 2003)) comporte une formule du style: [B ]=+ VITRINE LOUIS PHILIPPE ACAJOU[/B] et la cellule affiche alors #NOM? provoquant un plantage au traitement.

une solution : modifier manuellement ( !?)

autre solution ne pas les prendre en compte

je regarde pour modifier automatiquement

A+

Paf · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Re,

une autre macro intégrant la correction des erreurs du type relevé au post précédent et présentant l'avantage de tourner, pour 65534 lignes, en 1,5 s contre plus de 6 mn pour la macro du post #1

les résultats sont (curieusement) sensiblement identiques.

A noter il ne faut pas de ligne vide en début de colonne B, les données commençant en B2 (B1 = Libellé).

à tester

Code:

Sub Découpe()
 Dim FinB As Long, i As Long, j As Long
 Dim MonDico, TabB, Tabtemp, Start
 Dim Message
 Start = Timer
 With Worksheets("maison")
 FinB = .Range("B" & Rows.Count).End(xlUp).Row
 TabB = .Range("B2:B" & FinB)

 Set MonDico = CreateObject("Scripting.Dictionary")
 For i = LBound(TabB) To UBound(TabB)
 '***traitement des cellules avec formule
    If IsError(TabB(i, 1)) Then
        TabB(i, 1) = Right(.Cells(i + 1, 2).Formula, Len(.Cells(i + 1, 2).Formula) - 2)
        Message = Message & "Ligne " & i + 1 & "  erreur " & Chr(10)
    End If
 '***
    Tabtemp = Split(LCase(TabB(i, 1)), " ")
    For j = LBound(Tabtemp) To UBound(Tabtemp)
        MonDico(Tabtemp(j)) = MonDico(Tabtemp(j)) + 1
    Next
 Next
 .Range("E2").Resize(MonDico.Count) = Application.Transpose(MonDico.keys)
 .Range("F2").Resize(MonDico.Count) = Application.Transpose(MonDico.items)
 End With
 Message = Message & Chr(10) & Timer - Start
 MsgBox Message
End Sub

A+

magnusyou · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Hello Paf,

merci beaucoup pour ton aide,

Je viens de lancer la macro que tu me proposes mais je vois que je n'ai plus le nombre d'occurrence à côté de chaque mot?

Est-ce normal?

magnusyou

Paf · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Re,

les données sont en colonne E et le nombre d'occurrences en colonne E

A+

ED31 · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Merci pour ce beau problème,

Peut-on faire la même chose (scinder les textes d'une colonne en mots, ventilés sur plusieurs colonnes) et compter la fréquence des mots sans passer par VBA avec une formule pour chaque cellule (éventuellement formule matricielle).
Equivalent de la fonction Split de VBA, mais je sais cela n'existe pas et il faut le programmer.

Staple1600 · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Bonsoir à tous

ED31
L'usage est de poster sa question dans un fil de discussion que l'on aura soi-même initié
L'usage veut aussi qu'on suive (ou donne des nouvelles) dans ses fils récents
https://www.excel-downloads.com/thr...s-chaines-dune-liste-dans-une-cellule.229617/

klin89 · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Bonsoir à tous,

A tester sur quelques lignes :
J'ai l'impression que certains espaces sont assez conséquents.

VB:

Sub test()
Dim e, s, x, n As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each e In Range("B3", Range("B" & Rows.Count).End(xlUp)).Value
            If e <> "" Then
                For Each s In Split(e, " ")
                    .Item(s) = .Item(s) + 1
                Next
            End If
            x = Application.Transpose(Array(.keys, .Items))
            n = .Count
        Next
        With Range("B3").Offset(, 2).Resize(n, 2)
            .CurrentRegion.ClearContents
            .Value = x
        End With
    End With
End Sub

Le code suite à la remarque de Paf :

VB:

Sub test()
Dim e, s, x, n As Long
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each e In Range("B3", Range("B" & Rows.Count).End(xlUp)).Value
            If Not IsError(e) Then
                For Each s In Split(e, " ")
                    .Item(s) = .Item(s) + 1
                Next
            End If
            x = Application.Transpose(Array(.keys, .Items))
            n = .Count
        Next
        With Range("B3").Offset(, 2).Resize(n, 2)
            .CurrentRegion.ClearContents
            .Value = x
        End With
    End With
End Sub

Plus simplement pour nettoyer la colonne B, on peut introduire l'instruction suivante en début de code :

VB:

On Error Resume Next
    Columns("B:B").SpecialCells(xlCellTypeFormulas).Replace What:="=", Replacement:="", LookAt:=xlPart
On Error GoTo 0

klin89

Paf · 5 Mars 2015

Re : Macro Extraction et comptage de mot

Re et bonsoir Staple1600, klin89

@ klin89 malheureusement il y a plantage sur les lignes où on trouve une formule (objet du soucis de magnusyou)

je retiens le Application.Transpose(Array(.keys, .Items)) pour un prochain usage

Bonne soirée à tous

magnusyou · 18 Mars 2015

Re : Macro Extraction et comptage de mot

Paf,

Je me permets de revenir sur le sujet car je note que même en retirant les "+" dans les cellules des mots concernés j'ai toujours une erreur qui apparaît et cela me bloque la macro..

Pour la macro que tu proposes juste après la encore j'ai une erreur de type '1004' "Erreur définie par l'application ou par l'objet"?
Lors que je fais "débogage" j'ai cela de surligner en jaune:

.Range("E2").Resize(MonDico.Count) = Application.Transpose(MonDico.keys)

Vois-tu de quoi il s'agit?

Paf, j'ai absolument besoin que la macro travaille toutes les lignes du fichier (350K) c'est bien possible?

A ta dispo,

Bien à toi,

magnusyou,

Paf · 19 Mars 2015

Re : Macro Extraction et comptage de mot

re,

l'anomalie du =+...... est traitée dans la macro proposée au post #3

après différent essais, c'est le contenu de clés qui provoque l'anomalie. La première provient de la valeur =25w; après suppression du = ça plante plus loin sur une autre valeur contenant = et w.

Si un spécialiste peut expliquer pourquoi?

pas trouver d'autre solution que de remplacer le = par --, (ce pourrait être autre chose) ce qui ne rallonge pas trop le traitement: à peine 18 secondes pour les 341525 lignes sur mon vieux clou.

Code:

Sub Découpe()
 Dim FinB As Long, i As Long, j As Long, x() As Variant
 Dim MonDico, TabB, Tabtemp, Start
 Dim Message, rOutput As Range
 Start = Timer
 With Worksheets("maison")
 FinB = .Range("B" & Rows.Count).End(xlUp).Row
 TabB = .Range("B2:B" & FinB)

 Set MonDico = CreateObject("Scripting.Dictionary")
 For i = LBound(TabB) To UBound(TabB)
 '***traitement des cellules avec formule
    If IsError(TabB(i, 1)) Then
        TabB(i, 1) = Right(.Cells(i + 1, 2).Formula, Len(.Cells(i + 1, 2).Formula) - 2)
        Message = Message & "Ligne " & i + 1 & "  erreur " & Chr(10)
    End If
 '***
 '**** remplacement de = par --
    TabB(i, 1) = Replace(TabB(i, 1), "=", "--")
 '***
    Tabtemp = Split(LCase(TabB(i, 1)), " ")
    For j = LBound(Tabtemp) To UBound(Tabtemp)
        MonDico(Tabtemp(j)) = MonDico(Tabtemp(j)) + 1
    Next
 Next
 .Range("C2").Resize(MonDico.Count) = Application.Transpose(MonDico.keys)
 .Range("D2").Resize(MonDico.Count) = Application.Transpose(MonDico.Items)
 End With
 Message = Message & Chr(10) & Timer - Start
 MsgBox Message
End Sub

A+

Edit: j'ai déplacé l'affichage des résultats en colonnes C et D

Avez vous tester les autres propositions ?

magnusyou · 19 Mars 2015

Re : Macro Extraction et comptage de mot

Super Paf,

merci bcp ça marche

A très vite,

magnusyou

Macro Extraction et comptage de mot

magnusyou

XLDnaute Junior

Paf

XLDnaute Barbatruc

Paf

XLDnaute Barbatruc

magnusyou

XLDnaute Junior

Paf

XLDnaute Barbatruc

ED31

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

klin89

XLDnaute Accro

Paf

XLDnaute Barbatruc

magnusyou

XLDnaute Junior

Paf

XLDnaute Barbatruc

magnusyou

XLDnaute Junior

Discussions similaires