Code Doc is one of them, I am not.:pQuote:
Originally Posted by coolcurrent4u
I have spent 3 hours on another approach that is much faster as below. Code Doc and others are welcome to optimize it.
This only works with ANSI text file.
The test was run on WIN32API.TXT with filesize of 652KB that contains 86,445 words. After filtered it was reduced to 9,634 words.
The data reading from the text file is converted to lowercase and cleaned up to remove all non-English-alphabet characters.
All words are separated by single-spaces.
26 Dic strings are used to stored non-duplicated words found.
Code:Option Explicit
Sub FilterDuplicateWords()
Dim sFolder As String, sFName As String
Dim bData() As Byte, bData2() As Byte
Dim sData As String, sWord As String
Dim sDic(0 To 25) As String
Dim m(0 To 25) As Long
Dim bSpace As Byte, b As Byte
Dim i As Long, j As Long, n As Long, p As Long
Dim w(-1 To 26) As Long
Dim sMsg As String
Dim t As Single
t = Timer
sFolder = "C:\API\"
sFName = "WIN32API.TXT"
Open sFolder & sFName For Binary As #1
sData = Input(LOF(1), 1)
Close #1
sMsg = "Reading Data: " & vbTab & (Timer - t) & " seconds"
t = Timer
bData = StrConv(LCase(sData), vbFromUnicode)
sMsg = sMsg & vbCrLf & "Converting: " & vbTab & (Timer - t) & " seconds"
t = Timer
'-- clean up Data --------------------------------
ReDim bData2(UBound(bData) + 2)
bData2(0) = 32 '-- set a Space as first chararcter
bSpace = 1
j = 0
For i = 0 To UBound(bData)
Select Case bData(i)
Case 97 To 122: j = j + 1: bData2(j) = bData(i): bSpace = 0
Case Else: If bSpace Then Else j = j + 1: bData2(j) = 32: bSpace = 1
End Select
Next
If bSpace Then Else j = j + 1: bData2(j) = 32 '-- set a Space as last chararcter
ReDim Preserve bData2(j)
sData = StrConv(bData2, vbUnicode)
Erase bData, bData2
sMsg = sMsg & vbCrLf & "Cleaning up: " & vbTab & (Timer - t) & " seconds"
t = Timer
'-- Filering duplicate words ----------------------
For b = 0 To 25
sDic(b) = Space$(Len(sData)) '-- prepare rooms for Dic
m(b) = 1 '-- first space position in Dic(b)
Next
i = 1 '-- first space position in data
p = 1 '-- last space position in new data
Do While i < Len(sData)
j = InStr(i + 1, sData, " ") '-- next space position in data
n = j - i + 1 '-- len of word with leading and trailing spaces
sWord = Mid$(sData, i, n) '-- next word found in data
b = Asc(Mid$(sWord, 2, 1)) - 97 '-- index of Dic
w(-1) = w(-1) + 1 '-- original word counter
If InStrB(1, Left$(sDic(b), m(b)), sWord) = 0 Then '-- search Dic(b)
Mid$(sDic(b), m(b), n) = sWord '-- word not found, add to Dic
m(b) = m(b) + n - 1 '-- last space position in Dic(b)
w(b) = w(b) + 1 '-- Dic(b) word counter
Mid$(sData, p, n) = sWord '-- also add word to new data to pretend order
p = p + n - 1 '-- last space position in new data
w(26) = w(26) + 1 '-- new word counter
End If
i = j
Loop
sMsg = sMsg & vbCrLf & "Filtering: " & vbTab & (Timer - t) & " seconds"
t = Timer
'-- Saving filtered words ------------------
Open sFolder & "Words.txt" For Output As #1
Print #1, Mid$(sData, 1, p);
Close #1
sMsg = sMsg & vbCrLf & "Saving Data: " & vbTab & (Timer - t) & " seconds"
sMsg = sMsg & vbCrLf & vbCrLf & "Before Filtered: " & vbTab & w(-1) & " words"
sMsg = sMsg & vbCrLf & "After Filtered: " & vbTab & w(26) & " words"
For b = 0 To 25
sMsg = sMsg & vbCrLf & Chr$(b + 97) & " = " & w(b)
Next
MsgBox sMsg
sData = "": Erase sDic, m, w
End Sub
Code:Reading Data: 2.15625 seconds
Converting: 0.015625 seconds
Cleaning up: 0.265625 seconds
Filtering: 1.078125 seconds
Saving Data: 0.015625 seconds
Before Filtered: 86445 words
After Filtered: 9634 words
a = 386
b = 308
c = 774
d = 835
e = 446
f = 363
g = 588
h = 324
i = 489
j = 40
k = 39
l = 860
m = 465
n = 472
o = 244
p = 579
q = 50
r = 438
s = 983
t = 258
u = 189
v = 82
w = 357
x = 35
y = 21
z = 9
