Sub Contar_palabras()
'
' Contar_palabras Macro
'
'
Const maxwords = 10000 'Vamos a poner un limite para las palabras a contrar
Dim SingleWord As String 'vamos a tener esta variable para ir guardando las palabras
Dim Words(maxwords) As String 'Aqui vamos ir almacenando las palabras
Dim Freq(maxwords) As Integer 'Aqui vamos almacenar cada cuanto se repiten las palabras
Dim WordNum As Integer 'numero para ir contando cada palabra
Dim ByFreq As Boolean 'una banderita para ordenar por frecuencia
Dim ttlwds As Long 'contador de numero total de palabras
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'varibales para navegar entre los arreglos
Dim ans As String 'modo de ordenacmiento si por palabras o si por frecuencia
Dim tword As String
' Esta es una pantalla para preguntar como quiere el usuario ordenar las palabras
ByFreq = True
ans = InputBox("Como quieres ordener el resultado por PALABRA o por FRECUENCIA?", "Sort order", "PALABRA")
If ans = "" Then End
If UCase(ans) = "PALABRA" Then
ByFreq = False
End If
Selection.HomeKey Unit:=wdStory
System.Cursor = wdCursorWait
WordNum = 0
ttlwds = ActiveDocument.Words.Count
' Nuestro For each de busqueda
For Each aword In ActiveDocument.Words
SingleWord = Trim(LCase(aword))
'Out of range?
If SingleWord < "a" Or SingleWord > "z" Then
SingleWord = ""
End If
If Len(SingleWord) > 0 Then
Found = False
For j = 1 To WordNum
If Words(j) = SingleWord Then
Freq(j) = Freq(j) + 1
Found = True
Exit For
End If
Next j
If Not Found Then
WordNum = WordNum + 1
Words(WordNum) = SingleWord
Freq(WordNum) = 1
End If
If WordNum > maxwords - 1 Then
j = MsgBox("Lo maximo permitido son 9000", vbOKOnly)
Exit For
End If
End If
ttlwds = ttlwds - 1
StatusBar = "Remaining: " & ttlwds & ", Unique: " & WordNum
Next aword
' Ahora si a ordenar los datos
For j = 1 To WordNum - 1
k = j
For l = j + 1 To WordNum
If (Not ByFreq And Words(l) < Words(k)) _
Or (ByFreq And Freq(l) > Freq(k)) Then k = l
Next l
If k <> j Then
tword = Words(j)
Words(j) = Words(k)
Words(k) = tword
Temp = Freq(j)
Freq(j) = Freq(k)
Freq(k) = Temp
End If
StatusBar = "Ordenando: " & WordNum - j
Next j
' Escribimos los resultados en nuevo archivo de WORD
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For j = 1 To WordNum
.TypeText Text:=Trim(Str(Freq(j))) _
& vbTab & Words(j) & vbCrLf
Next j
End With
System.Cursor = wdCursorNormal
j = MsgBox("Se encontraron " & Trim(Str(WordNum)) & _
" Palabras Diferentes ", vbOKOnly, "Finished")
End Sub
Así debe quedar en la pantalla
Ahora vamos a ejecutarla
Nos va a preguntar como queremos ordenar los datos
Como resultado vamos a ver un nuevo archivo de word con cada palabra y cada cuanto se repite
Espero les sea de utilidad y nos compartan
Comentarios
Publicar un comentario
Dejanos tus dudas y comentarios