M
mkboynton via OfficeKB.com
I need to count number in a word .doc file. This is an example of a page...
3/23/06 S H I P P I N G S U M M A R Y W O R K S H E E T
WM0490 PAGE 1
RUN DATE 3/23/06
0 ------ T O T A L --
----
STORE SEQ CITY ST--ZIP-- PHONE CUBE WEIGHT
CASES SCHED DEL/DAY SHIP NO NAME EXCEPTIONS
0 6032_____010 FLORIDA CITY FL 33034 305-248-7341 1880 28697
1605 500 MON 2892267 ________
5114_____020 MIAMI FL 33138 305-751-1550 737 10802
621 500 MON 2892245 ________ DELIVER 6:30AM
------ ------ --
----
TOTAL SCHEDULE: 2618 39500
2226 49
Monday SWIFT 3/1109/529
*5114 6:30AM DELIVERY
176019
- DATE 3/23/06 S H I P P I N G S U M M A R Y W O R K S H E E
T WM0490 PAGE 2
RUN DATE 3/23/06
0 ______ T O T A L
______
STORE SEQ CITY ST--ZIP-- PHONE CUBE WEIGHT
CASES SCHED DEL/DAY SHIP NO NAME EXCEPTIONS
0 5909_____010 MIAMI FL 33147 786-318-2560 2608 40448
2029 501 MON 2892263 ________
------ ------ --
----
TOTAL SCHEDULE: 2608 40448
2029 49
Monday SWIFT 2/1056/528
176020
This has word wrapped by the way...
The number I need to count are the ones that appear under the SCHED header.
I am using the following macros which does a good job, but it also counts the
same numbers if the appear elsewhere in the document.
Sub WordFrequency()
Dim SingleWord As String 'Raw word pulled from doc
Const maxwords = 9000 'Maximum unique words allowed
Dim Words(maxwords) As String 'Array to hold unique words
Dim Freq(maxwords) As Integer 'Frequency counter for unique
Words
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim ttlwds As Long 'Total words in the document
Dim Excludes As String 'Words to be excluded
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim tword As String '
Dim pword As String 'Previous word
Dim cword As String 'Current word
Dim newword As String 'Combined words
Dim StartNum
Dim EndNum
' Set up excluded words
Excludes = "[the][a][of][is][to][for][this][that][by][be][and][are]
[am][pm]"
' Find out how to sort
ByFreq = False
'Ans = InputBox$("Sort by WORD or by FREQ?", "Sort order", "WORD")
'If Ans = "" Then End
'If UCase(Ans) = "FREQ" Then
' ByFreq = True
'End If
StartNum = InputBox$("Starting Route Number?", "Start Number")
EndNum = InputBox$("Ending Route Number?", "Ending Number")
Selection.HomeKey Unit:=wdStory
System.Cursor = wdCursorWait
WordNum = 0
ttlwds = ActiveDocument.Words.Count
' Control the repeat
For Each aword In ActiveDocument.Words
SingleWord = Trim(LCase(aword))
cword = Trim(LCase(aword))
newword = pword & cword
'If Mid(newword, 4, 1) = "-" Then
'MsgBox "Combined Word is " & newword
'End If
If Mid(newword, 4, 1) = "-" Then
SingleWord = ""
End If
'If SingleWord < "0" Or SingleWord > "9" Then SingleWord = ""
'Out of range?
If SingleWord < StartNum Or SingleWord > EndNum Then SingleWord =
""
If Len(SingleWord) <> 3 Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "a") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "p") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "s") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "r") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "n") Then SingleWord = ""
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = ""
'On exclude list?
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("The maximum array size has been exceeded.
Increase maxwords.", vbOKOnly)
Exit For
End If
End If
ttlwds = ttlwds - 1
StatusBar = "Remaining: " & ttlwds & " Unique: " & WordNum
pword = cword
Next aword
' Now sort it into word order
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)
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 = "Sorting: " & WordNum - j
Next j
' Now write out the results
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For j = 1 To WordNum
.TypeText Text:=Words(j) & vbTab & Trim(Str(Freq(j))) &
vbCrLf
Next j
End With
ActiveDocument.Range.Select
Selection.ConvertToTable , , , 125
Selection.Collapse wdCollapseStart
ActiveDocument.Tables(1).Rows.Add BeforeRow:=Selection.Rows(1)
ActiveDocument.Tables(1).Cell(1, 1).Range.InsertBefore "Route #"
ActiveDocument.Tables(1).Cell(1, 2).Range.InsertBefore "Number of
Stores"
ActiveDocument.Tables(1).Range.ParagraphFormat.Alignment =
wdAlignParagraphCenter
System.Cursor = wdCursorNormal
'j = MsgBox("There were " & Trim(Str(WordNum)) & " routes ", vbOKOnly,
"Finished")
Selection.HomeKey wdStory
'ActiveDocument.SaveAs FileName:=StartNum & "'s count"
End Sub
Is there a way to have it only count the numbers that appear under the word
SCHED in the document or count only the numbers that have a space before and
after them?
3/23/06 S H I P P I N G S U M M A R Y W O R K S H E E T
WM0490 PAGE 1
RUN DATE 3/23/06
0 ------ T O T A L --
----
STORE SEQ CITY ST--ZIP-- PHONE CUBE WEIGHT
CASES SCHED DEL/DAY SHIP NO NAME EXCEPTIONS
0 6032_____010 FLORIDA CITY FL 33034 305-248-7341 1880 28697
1605 500 MON 2892267 ________
5114_____020 MIAMI FL 33138 305-751-1550 737 10802
621 500 MON 2892245 ________ DELIVER 6:30AM
------ ------ --
----
TOTAL SCHEDULE: 2618 39500
2226 49
Monday SWIFT 3/1109/529
*5114 6:30AM DELIVERY
176019
- DATE 3/23/06 S H I P P I N G S U M M A R Y W O R K S H E E
T WM0490 PAGE 2
RUN DATE 3/23/06
0 ______ T O T A L
______
STORE SEQ CITY ST--ZIP-- PHONE CUBE WEIGHT
CASES SCHED DEL/DAY SHIP NO NAME EXCEPTIONS
0 5909_____010 MIAMI FL 33147 786-318-2560 2608 40448
2029 501 MON 2892263 ________
------ ------ --
----
TOTAL SCHEDULE: 2608 40448
2029 49
Monday SWIFT 2/1056/528
176020
This has word wrapped by the way...
The number I need to count are the ones that appear under the SCHED header.
I am using the following macros which does a good job, but it also counts the
same numbers if the appear elsewhere in the document.
Sub WordFrequency()
Dim SingleWord As String 'Raw word pulled from doc
Const maxwords = 9000 'Maximum unique words allowed
Dim Words(maxwords) As String 'Array to hold unique words
Dim Freq(maxwords) As Integer 'Frequency counter for unique
Words
Dim WordNum As Integer 'Number of unique words
Dim ByFreq As Boolean 'Flag for sorting order
Dim ttlwds As Long 'Total words in the document
Dim Excludes As String 'Words to be excluded
Dim Found As Boolean 'Temporary flag
Dim j, k, l, Temp As Integer 'Temporary variables
Dim tword As String '
Dim pword As String 'Previous word
Dim cword As String 'Current word
Dim newword As String 'Combined words
Dim StartNum
Dim EndNum
' Set up excluded words
Excludes = "[the][a][of][is][to][for][this][that][by][be][and][are]
[am][pm]"
' Find out how to sort
ByFreq = False
'Ans = InputBox$("Sort by WORD or by FREQ?", "Sort order", "WORD")
'If Ans = "" Then End
'If UCase(Ans) = "FREQ" Then
' ByFreq = True
'End If
StartNum = InputBox$("Starting Route Number?", "Start Number")
EndNum = InputBox$("Ending Route Number?", "Ending Number")
Selection.HomeKey Unit:=wdStory
System.Cursor = wdCursorWait
WordNum = 0
ttlwds = ActiveDocument.Words.Count
' Control the repeat
For Each aword In ActiveDocument.Words
SingleWord = Trim(LCase(aword))
cword = Trim(LCase(aword))
newword = pword & cword
'If Mid(newword, 4, 1) = "-" Then
'MsgBox "Combined Word is " & newword
'End If
If Mid(newword, 4, 1) = "-" Then
SingleWord = ""
End If
'If SingleWord < "0" Or SingleWord > "9" Then SingleWord = ""
'Out of range?
If SingleWord < StartNum Or SingleWord > EndNum Then SingleWord =
""
If Len(SingleWord) <> 3 Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "a") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "p") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "s") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "r") Then SingleWord = ""
If InStr(2, "[" & SingleWord & "]", "n") Then SingleWord = ""
If InStr(Excludes, "[" & SingleWord & "]") Then SingleWord = ""
'On exclude list?
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("The maximum array size has been exceeded.
Increase maxwords.", vbOKOnly)
Exit For
End If
End If
ttlwds = ttlwds - 1
StatusBar = "Remaining: " & ttlwds & " Unique: " & WordNum
pword = cword
Next aword
' Now sort it into word order
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)
Next lFreq(k)) Then k = 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 = "Sorting: " & WordNum - j
Next j
' Now write out the results
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
Selection.ParagraphFormat.TabStops.ClearAll
With Selection
For j = 1 To WordNum
.TypeText Text:=Words(j) & vbTab & Trim(Str(Freq(j))) &
vbCrLf
Next j
End With
ActiveDocument.Range.Select
Selection.ConvertToTable , , , 125
Selection.Collapse wdCollapseStart
ActiveDocument.Tables(1).Rows.Add BeforeRow:=Selection.Rows(1)
ActiveDocument.Tables(1).Cell(1, 1).Range.InsertBefore "Route #"
ActiveDocument.Tables(1).Cell(1, 2).Range.InsertBefore "Number of
Stores"
ActiveDocument.Tables(1).Range.ParagraphFormat.Alignment =
wdAlignParagraphCenter
System.Cursor = wdCursorNormal
'j = MsgBox("There were " & Trim(Str(WordNum)) & " routes ", vbOKOnly,
"Finished")
Selection.HomeKey wdStory
'ActiveDocument.SaveAs FileName:=StartNum & "'s count"
End Sub
Is there a way to have it only count the numbers that appear under the word
SCHED in the document or count only the numbers that have a space before and
after them?