Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel calcul du nombre de chaque mot d'un texte

calcul du nombre de chaque mot d'un texte

51 réponses
Avatar
eric.zzzz
Bonjour,
Comment calculer le nombre de chaque mot d'un texte (en word ou en pdf que =
je pourrais copier dans excel si n=E9cessaire)
Merci d'avance
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
2 3 4 5 6
Avatar
DanielCo
D'accord, j'ai oublié la virgule dans la liste des caractères à
éliminer :
Sub Compte()
Dim Tabl, Item, Txt As String, C As Range, Ligne As Long, Ctr, Dico
As Object
Dim Result() As Long
deb = Timer
Application.ScreenUpdating = False
Sheets(2).[A:B].ClearContents
Tabl = Array("'", "(", ")", ".", ";", "=", ",") 'etc.
For Each Item In Tabl
[A:A].Replace Item, " "
Next Item
Set Dico = CreateObject("Scripting.Dictionary")
For i = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row Step 100
With Sheets(1)
Txt = ""
Dico.RemoveAll
ReDim Result(0)
Ctr = -1
For Each C In .Range(.Cells(i, 1), .Cells(i + 99,
1).End(xlUp))
Txt = Txt & " " & C.Value
Next C
Txt = Right(Txt, Len(Txt) - 1)
Tabl = Split(Txt, " ")
For Each Item In Tabl
If Item <> "" Then
If Not Dico.exists(Item) Then
Dico.Add Item, Item
Ctr = Ctr + 1
ReDim Preserve Result(Ctr)
Result(Ctr) = Result(Ctr) + 1
Else
Pos = Application.Match(Item, Dico.items, 0)
Result(Pos - 1) = Result(Pos - 1) + 1
End If
End If
Next Item
End With
With Sheets(2)
For x = 0 To Dico.Count - 1
Ligne = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Var = Dico.items
If Not IsNumeric(Application.Match(Var(x), .[A:A], 0))
Then
Var1 = Var(x)
.Cells(Ligne, 1).Value = Var(x)
.Cells(Ligne, 2) = Result(x)
Else
Ligne = Application.Match(Var(x), .[A:A], 0)
.Cells(Ligne, 2) = .Cells(Ligne, 2) + Result(x)
End If
Next x
End With
Next i
MsgBox Timer - deb
Application.ScreenUpdating = True
End Sub
Sub Compte2()
Dim Item, Txt As String, C As Range, Pos As Long
Application.ScreenUpdating = False
Sheets(2).[A:B].ClearContents
Tabl = Array("'", "(", ")", ".", ";") 'etc.
For Each Item In Tabl
[A:A].Replace Item, " "
Next Item
With Sheets(1)
For Each C In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
Txt = Txt & " " & C.Value
Next C
End With
With Sheets(2)
.[A1] = "Mots"
.[B1] = "Nombres"
Txt = Right(Txt, Len(Txt) - 1)
Tabl = Split(Txt, " ")
For Each Item In Tabl
If Item <> "" Then
If Not IsNumeric(Application.Match(Item, .[A:A], 0))
Then
Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
C.Value = Item
C.Offset(, 1) = 1
Else
Pos = Application.Match(Item, .[A:A], 0)
.Cells(Pos, 2) = .Cells(Pos, 2) + 1
End If
End If
Next Item
End With
Application.ScreenUpdating = True
MsgBox Timer - deb
' With Sheets(2)
' For i = 0 To Dico.Count - 1
' Ligne = Ligne + 1
' Var = Dico.items
' .Cells(Ligne, 1) = Var(i)
' .Cells(Ligne, 2) = Result(i)
' Next i
' End With
End Sub

Daniel


"DanielCo" a écrit dans le message de news:
kqgqba$plt$


Peux-tu mettre 3 ou 4 lignes (avec des virgules)sur cjoint.com.



http://cjoint.com/?3FBlrGK9dDS



--- news://freenews.netfront.net/ - complaints: ---
Avatar
moi
Le jeudi 27 juin 2013 14:57:56 UTC+2, DanielCo a écrit :
D'accord, j'ai oublié la virgule dans la liste des caractères à

éliminer :

Sub Compte()

Dim Tabl, Item, Txt As String, C As Range, Ligne As Long, Ctr, Dico

As Object

Dim Result() As Long

deb = Timer

Application.ScreenUpdating = False

Sheets(2).[A:B].ClearContents

Tabl = Array("'", "(", ")", ".", ";", "=", ",") 'etc.

For Each Item In Tabl

[A:A].Replace Item, " "

Next Item

Set Dico = CreateObject("Scripting.Dictionary")

For i = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row Step 100

With Sheets(1)

Txt = ""

Dico.RemoveAll

ReDim Result(0)

Ctr = -1

For Each C In .Range(.Cells(i, 1), .Cells(i + 99,

1).End(xlUp))

Txt = Txt & " " & C.Value

Next C

Txt = Right(Txt, Len(Txt) - 1)

Tabl = Split(Txt, " ")

For Each Item In Tabl

If Item <> "" Then

If Not Dico.exists(Item) Then

Dico.Add Item, Item

Ctr = Ctr + 1

ReDim Preserve Result(Ctr)

Result(Ctr) = Result(Ctr) + 1

Else

Pos = Application.Match(Item, Dico.items, 0)

Result(Pos - 1) = Result(Pos - 1) + 1

End If

End If

Next Item

End With

With Sheets(2)

For x = 0 To Dico.Count - 1

Ligne = .Cells(Rows.Count, 1).End(xlUp).Row + 1

Var = Dico.items

If Not IsNumeric(Application.Match(Var(x), .[A:A], 0))

Then

Var1 = Var(x)

.Cells(Ligne, 1).Value = Var(x)

.Cells(Ligne, 2) = Result(x)

Else

Ligne = Application.Match(Var(x), .[A:A], 0)

.Cells(Ligne, 2) = .Cells(Ligne, 2) + Result(x)

End If

Next x

End With

Next i

MsgBox Timer - deb

Application.ScreenUpdating = True

End Sub

Sub Compte2()

Dim Item, Txt As String, C As Range, Pos As Long

Application.ScreenUpdating = False

Sheets(2).[A:B].ClearContents

Tabl = Array("'", "(", ")", ".", ";") 'etc.

For Each Item In Tabl

[A:A].Replace Item, " "

Next Item

With Sheets(1)

For Each C In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))

Txt = Txt & " " & C.Value

Next C

End With

With Sheets(2)

.[A1] = "Mots"

.[B1] = "Nombres"

Txt = Right(Txt, Len(Txt) - 1)

Tabl = Split(Txt, " ")

For Each Item In Tabl

If Item <> "" Then

If Not IsNumeric(Application.Match(Item, .[A:A], 0))

Then

Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)

C.Value = Item

C.Offset(, 1) = 1

Else

Pos = Application.Match(Item, .[A:A], 0)

.Cells(Pos, 2) = .Cells(Pos, 2) + 1

End If

End If

Next Item

End With

Application.ScreenUpdating = True

MsgBox Timer - deb

' With Sheets(2)

' For i = 0 To Dico.Count - 1

' Ligne = Ligne + 1

' Var = Dico.items

' .Cells(Ligne, 1) = Var(i)

' .Cells(Ligne, 2) = Result(i)

' Next i

' End With

End Sub



Daniel





> "DanielCo" a écrit dans le message de news:

> kqgqba$plt$




Non, ça coince toujours sur
.Cells(Pos, 2) = .Cells(Pos, 2) + 1

erreur 13 incompatibilité de type

Peut-on le faire avec Access ?
Si oui, je dois poster ici ou sur MPFA ?
Avatar
DanielCo
Non, ça coince toujours sur
.Cells(Pos, 2) = .Cells(Pos, 2) + 1

erreur 13 incompatibilité de type

Peut-on le faire avec Access ?
Si oui, je dois poster ici ou sur MPFA ?



Par erreur, j'ai posté 2 macros et manque de chance, tu as pris la
mauvaise. Il faut utiliser "Compte", pas "Compte2", désolé. Sinon, je
ne vois pas comment le faire avec Access, mais je ne suis pas un pro.
Poste de préférence sur le forum Access.
Daniel
Avatar
moi
Le jeudi 27 juin 2013 18:34:50 UTC+2, DanielCo a écrit :



Par erreur, j'ai posté 2 macros et manque de chance, tu as pris la

mauvaise. Il faut utiliser "Compte", pas "Compte2", désolé. Sinon, je

ne vois pas comment le faire avec Access, mais je ne suis pas un pro.

Poste de préférence sur le forum Access.

Daniel



ok , je verrais ça demain, mais est-ce bien cette macro qu'il faut prendr e ?

Sub Compte()
Dim Tabl, Item, Txt As String, C As Range, Ligne As Long, Ctr, Dico
As Object
Dim Result() As Long
deb = Timer
Application.ScreenUpdating = False
Sheets(2).[A:B].ClearContents
Tabl = Array("'", "(", ")", ".", ";", "=", ",") 'etc.
For Each Item In Tabl
[A:A].Replace Item, " "
Next Item
Set Dico = CreateObject("Scripting.Dictionary")
For i = 1 To Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row Step 100
With Sheets(1)
Txt = ""
Dico.RemoveAll
ReDim Result(0)
Ctr = -1
For Each C In .Range(.Cells(i, 1), .Cells(i + 99,
1).End(xlUp))
Txt = Txt & " " & C.Value
Next C
Txt = Right(Txt, Len(Txt) - 1)
Tabl = Split(Txt, " ")
For Each Item In Tabl
If Item <> "" Then
If Not Dico.exists(Item) Then
Dico.Add Item, Item
Ctr = Ctr + 1
ReDim Preserve Result(Ctr)
Result(Ctr) = Result(Ctr) + 1
Else
Pos = Application.Match(Item, Dico.items, 0)
Result(Pos - 1) = Result(Pos - 1) + 1
End If
End If
Next Item
End With
With Sheets(2)
For x = 0 To Dico.Count - 1
Ligne = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Var = Dico.items
If Not IsNumeric(Application.Match(Var(x), .[A:A], 0))
Then
Var1 = Var(x)
.Cells(Ligne, 1).Value = Var(x)
.Cells(Ligne, 2) = Result(x)
Else
Ligne = Application.Match(Var(x), .[A:A], 0)
.Cells(Ligne, 2) = .Cells(Ligne, 2) + Result(x)
End If
Next x
End With
Next i
MsgBox Timer - deb
Application.ScreenUpdating = True
End Sub
Avatar
DanielCo
ok , je verrais ça demain, mais est-ce bien cette macro qu'il faut prendre
?

Sub Compte()



Oui.
Daniel
Avatar
moi
Le vendredi 28 juin 2013 09:59:21 UTC+2, DanielCo a écrit :
> ok , je verrais ça demain, mais est-ce bien cette macro qu'il faut pr endre



Oui.




Au bureau, c'est trop long et ça n'aboutit pas. Le soir au moins ça abo utit sur un bug; donc je verrais ça ce soir
Avatar
DanielCo
J'ai utilisé le dernier code proposé, au bout de 35 mn j'ai laissé tomber
Je t'ai contacté par email, mais j'ai reçu un Undelivered Mail Returned to
Sender



Utilise en enlevant les "ZZZ". Ca serait bien
que tu puisses envoyer le texte que je voie pourquoi ça plante.
Daniel
Avatar
moi
Le vendredi 28 juin 2013 10:47:15 UTC+2, DanielCo a écrit :
. Ca serait bien

que tu puisses envoyer le texte que je voie pourquoi ça plante.




c'est fait
Avatar
moi
Le vendredi 28 juin 2013 10:47:15 UTC+2, DanielCo a écrit :
. Ca serait bien

que tu puisses envoyer le texte que je voie pourquoi ça plante.

Daniel



Tabl = Array("'", "(", ")", ".", ";", "=", ",", "?", ":", "!") 'etc.
For Each Item In Tabl
[A:A].Replace Item, " "
Next Item

J'ai constaté qu'il ne supprime pas les ?, : et ! , même avec Ctrl + H
Comment faire ?
Avatar
DanielCo
Le vendredi 28 juin 2013 10:47:15 UTC+2, DanielCo a écrit :
. Ca serait bien

que tu puisses envoyer le texte que je voie pourquoi ça plante.




c'est fait



Je n'ai rien reçu... Quelle est la taille du fichier ?
Daniel
2 3 4 5 6