PDA

View Full Version : Extract unique words from textbox



swaggerbox
11-05-2015, 04:32 AM
I have a userform (userform2) with a textbox (textbox1). How do I extract all the unique words in the textbox and display all the words in a label (label10) with a corresponding count (or frequency). For example, if the value in textbox1 is "Hey mister there is a donut", then result should be displayed in label10 "hey (1) mister (1) there (1) is (1) a (1) donut (1)" Or maybe a tag cloud (http://www.nngroup.com/articles/tag-cloud-examples/) of some sort but I know that's a little complicated. Any ideas?

katanga
11-05-2015, 08:28 AM
Hi,

something like this functin ?



Function countWords(sWords As String) As String
Dim w As cWord 'Word object
Dim c As New Collection 'Collection of wrds
Dim a 'Array of words
Dim i As Integer, i1 As Integer, i2 As Integer ' Index counters
Dim k As String 'Key for colelctin
Dim r As String 'result

a = Split(sWords, " ")
i1 = LBound(a)
i2 = UBound(a)

For i = i1 To i2
k = a(i)
On Error Resume Next
If c(k).word = "" Then
Set w = New cWord
w.word = k
c.Add Item:=w, Key:=k
Else
c(k).Inc
End If
On Error GoTo 0
Next i
r = ""
For Each w In c
r = r & w.word & " (" & w.count & ") "
Next w
countWords = r
End Function


you may define the class moducle cWord


Dim sWord As String
Dim iCount As Integer

Public Property Get word() As String
word = sWord
End Property
Public Property Let word(ByVal sNewValue As String)
sWord = sNewValue
End Property

Public Property Get count() As String
count = iCount
End Property
Public Sub Inc()
iCount = iCount + 1
End Sub

Private Sub Class_Initialize()
iCount = 1
End Sub

JKwan
11-05-2015, 08:34 AM
try this

Private Sub CommandButton1_Click()
Dim myArray As Variant
Dim dDictionary As Object
Dim Index As Long

myArray = Split(Me.TextBox1.Text, " ")
Set dDictionary = CreateObject("scripting.dictionary")
For Index = 0 To UBound(myArray)
dDictionary(myArray(Index)) = dDictionary(myArray(Index)) + 1
Next

With Worksheets("Sheet1")
.[A1:B200].Clear
.[A1:B1] = Split("Item Frequency", " ")
.[A2].Resize(dDictionary.Count) = Application.Transpose(dDictionary.Keys)
.[B2].Resize(dDictionary.Count) = Application.Transpose(dDictionary.Items)
End With
Set dDictionary = Nothing
End Sub

snb
11-05-2015, 08:44 AM
Sub M_snb()
c00 = "Daar wordt aan de deur geklopt"
sn = Split(c00)

With CreateObject("scripting.dictionary")
For Each it In sn
.Item(it) = .Item(it) + 1
Next

For Each it In .keys
c01 = c01 & vbLf & it & " (" & .Item(it) & ")"
Next
End With

MsgBox c01
End Sub

mancubus
11-05-2015, 10:42 AM
my two cents:

Scripting dictionary's default CompareMode property is 0 or vbBinaryCompare which makes text comparison case sensitive. use this value if 'This' and 'this' are different.

Case Sensitive


With CreateObject("Scripting.Dictionary")
.CompareMode = vbBinaryCompare
End With

or

With CreateObject("Scripting.Dictionary")
.CompareMode = 0
End With

or

With CreateObject("Scripting.Dictionary")
End With




if 'This' and 'this' are the same

Case Insensitive


With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
End With

or

With CreateObject("Scripting.Dictionary")
.CompareMode = 1
End With

swaggerbox
11-05-2015, 10:04 PM
thanks everyone. you are all such a big help!

snb
11-06-2015, 01:10 AM
It can also be written as:


Sub M_snb()
c00 = "Daar wordt aan de deur geklopt, hard geklopt, zacht geklopt"
sn = Split(Replace(c00, ",", ""))

With CreateObject("scripting.dictionary")
For Each it In sn
.Item(it) = .Item(it) + 1
Next

MsgBox Join(Evaluate("index({""" & Join(.keys(), """,""") & """}&char(9)&{" & Join(.items, ",") & "},)"), vbLf)
End With
End Sub