Thread: How to splitt texts into words? (collecting word and compounds)

...
Can you change

            If UBound(x) = 0 Then
                If Not dic1.exists(x(0)) Then
                    dic1.add x(0), Nothing
                    n1 = n1 + 1 : ColA(n1, 1) = x(0)
                Else

to

            If UBound(x) = 0 Then
                If Not dic.exists(x(0)) Then
                    dic.add x(0), Nothing
                    n1 = n1 + 1 : ColA(n1, 1) = x(0)
                Else

Jindon, i am realy sorry! but not working yet. It doesnt add words to the columns.

OK
Can you return with the message?

Sub test()
Dim a, e, dic As Object, x
Dim ColA(), ColC(), ColE(), n1 As Long, n2 As Long, n3 As Long
ReDim ColA(1 To Rows.Count, 1 To 1), ColC(1 To Rows.Count, 1 To 1)
ReDim ColE(1 To Rows.Count, 1 To 1)
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Sheets("words").Range("a1").CurrentRegion.Resize(,7).Value
For Each e In a
    If (Not IsEmpty(e)) * (Not dic.exists(e)) Then dic.add e, Nothing
Next
With Sheets("text")
    a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
End With
With CreateObject("VBScript.RegExp")
    .Pattern = "[\(\)\[\]_\.,-\?!<>\+\*:;]"
    .Global = True
    For Each e In a
        If Not IsEmpty(e) Then
            MsgBox "Before" & vbLf & e
            x = Split(WorksheetFunction.Trim(.replace(e,"")))
            MsgBox "After" & vbLf & WorksheetFunction.Trim(.replace(e,""))
            If UBound(x) = 0 Then
                If Not dic.exists(x(0)) Then
                    dic.add x(0), Nothing
                    n1 = n1 + 1 : ColA(n1, 1) = x(0)
                Else
                    For i = 0 To UBound(x) - 1
                        temp = x(i) & " " & x(i + 1)
                        If Not dic.exists(temp) Then
                            n2 = n2 + 1 : ColC(n2, 1) = temp
                        End If
                        If (i <=UBound(x) - 2) Then
                            temp = x(i) & " " & x(i + 1) & " " & x(i + 2)
                            If Not dic.exists(temp) Then
                                n3 = n3 + 1 : ColE(n3, 1) = temp
                            End If
                        End If
                    Next
                End If
            End If
        End If
    Next
End With
With Sheets("words")
    If n1 > 0 Then .Range("a" & Rows.Count).End(xlUp)(2).Resize(n1).Value = ColA
    If n2 > 0 Then .Range("c" & Rows.Count).End(xlUp(2).Resize(n2).Value = ColC
    If n3 > 0 Then .Range("e" & Rows.Count).End(xlUp)(2).Resize(n3).Value = ColE
End With
End Sub

Jindon,
when run, the macro shows me the message "before" and "afeter". The difference is that in "after" it shows the strings without the signs.
It shows error if only the first row has a string. It works only if at least one row below the first row in "text" contains a string. => yes it shows the messagebox

But still the same problem. Its not adding words to the columns.=> not adding words yet :-(

OK
How about?

Sub test()
Dim a, e, r As Range, rng As Range, dic As Object, x
Dim ColA(), ColC(), ColE(), n1 As Long, n2 As Long, n3 As Long
ReDim ColA(1 To Rows.Count, 1 To 1), ColC(1 To Rows.Count, 1 To 1)
ReDim ColE(1 To Rows.Count, 1 To 1)
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = vbTextCompare
a = Sheets("words").Range("a1").CurrentRegion.Resize(,7).Value
For Each e In a
    If (Not IsEmpty(e)) * (Not dic.exists(e)) Then dic.add e, Nothing
Next
With Sheets("text")
    Set rng = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
End With
With CreateObject("VBScript.RegExp")
    .Pattern = "[\(\)\[\]_\.,-\?!<>\+\*:;]"
    .Global = True
    For Each r In rng
        If Not IsEmpty(r.Value) Then
            x = Split(WorksheetFunction.Trim(.replace(r.Value,"")))
            If UBound(x) = 0 Then
                If Not dic.exists(x(0)) Then
                    dic.add x(0), Nothing
                    n1 = n1 + 1 : ColA(n1, 1) = x(0)
                End If
            Else
                For i = 0 To UBound(x) - 1
                    temp = x(i) & " " & x(i + 1)
                    If Not dic.exists(temp) Then
                        n2 = n2 + 1 : ColC(n2, 1) = temp
                    End If
                    If (i <=UBound(x) - 2) Then
                        temp = x(i) & " " & x(i + 1) & " " & x(i + 2)
                        If Not dic.exists(temp) Then
                            n3 = n3 + 1 : ColE(n3, 1) = temp
                        End If
                    End If                     
                Next
            End If
        End If
    Next        
End With
With Sheets("words")
    If n1 > 0 Then .Range("a" & Rows.Count).End(xlUp)(2).Resize(n1).Value = ColA
    If n2 > 0 Then .Range("c" & Rows.Count).End(xlUp(2).Resize(n2).Value = ColC
    If n3 > 0 Then .Range("e" & Rows.Count).End(xlUp)(2).Resize(n3).Value = ColE
End With
End Sub

ok it works but only for two and three words column. No words are added to the A column. Can you plz fix that as well. thanks

Thanks alot. It works. It adds words to all three columns.

But there is one problem remaining. It adds duplicates which should not be.
If words already exist there they are not added. But if one word is more times there in the string in "text" worksheet its added multiple times to the columns in "words". => if one word is added once then it should not be added again!!

everthing is working well. thanks a million times! i dont know how to thank you. Thanks alot for your patience. thanks a million times!!!!!!