Hi Robert,

Am Sun, 10 May 2015 21:05:38 +0200 schrieb Claus Busch:

Sub Test2()

better:

sorry but you get an error if you have no numbers in your text.

Try:

Sub Test2()
'New 2015-05-09 C.B.
'Revised 2015-05-10 C.B.
Dim strPath As String
Dim strFN As String
Dim objReadFile As Object, myDic As Object, objFSO As Object, re As
Object
Dim strText As String
Dim varText() As Variant, varOut As Variant, varTmp() As Variant
Dim i As Long, LRow As Long, n As Long
Dim ptrn, Match, Matches
Dim FERow As Range

Application.ScreenUpdating = False

'Modify path and file name
strPath = "C:\Users\Claus\Desktop\"
strFN = "Test.txt"

Set myDic = CreateObject("Scripting.Dictionary")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set re = CreateObject("vbscript.regexp")

'Opens the text file and read the text into a string
Set objReadFile = objFSO.opentextfile(strPath & strFN)

Do While objReadFile.atendofstream < True
strText = strText & objReadFile.readline & " "
Loop
objReadFile.Close

'Handles special cases like I'll, it's and so on
'Customize it depending on your text file
strText = Replace(Replace(Replace(Replace(Replace(Replace(st rText, _
"'s ", " is "), "'ll ", " will "), "'d ", " had "), "'re ", _
" are "), "'ve ", " have "), "'m ", " am ")
strText = Application.Trim(strText)

'Separate all "words"
ptrn = "\w+"
re.Pattern = ptrn
re.IgnoreCase = False
re.Global = True
Set Matches = re.Execute(strText)
ReDim Preserve varText(Matches.Count - 1)
For Each Match In Matches
varText(n) = LCase(Match.Value)
n = n + 1
Next

'Create unique words
For i = LBound(varText) To UBound(varText)
myDic(varText(i)) = varText(i)
Next
varOut = myDic.items

'Distrubutes the words in alphabetic order to columns
Range("A1") = "Header"
Range("A2").Resize(UBound(varOut) + 1) = _
Application.Transpose(varOut)
LRow = Cells(Rows.Count, 1).End(xlUp).Row
n = 2
For i = 97 To 122
Range("A1:A" & LRow).AutoFilter Field:=1, Criteria1:="=" & Chr(i) &
"*"
If Application.Subtotal(3, Range("A:A")) 1 Then
Range("A2:A" & LRow).Copy Cells(1, n)
End If
n = n + 1
Next
n = 0
If Application.Count(Range("A:A")) 0 Then
For i = LBound(varOut) To UBound(varOut)
If IsNumeric(varOut(i)) Then
ReDim Preserve varTmp(n)
varTmp(n) = varOut(i)
n = n + 1
End If
Next
End If
ActiveSheet.AutoFilterMode = False
If n 0 Then
Range("AB1").Resize(n) = Application.Transpose(varTmp)
End If

Columns("A").Delete
Columns("A:AA").AutoFit
Application.ScreenUpdating = True
End Sub


Regards
Claus B.
--
Vista Ultimate / Windows7
Office 2007 Ultimate / 2010 Professional