Words Statistic Makro

[markos97]

Hello!

I want to create a word statistic. Someone on a polish forum help
me with this, but partially. In this moment "my" code output the following
results: words, frequency of occurence, and page number.

Option Explicit
Option Compare Text
Sub Test()

    Dim lngRes                    As Long
    lngRes = WordCountAndPages(ThisDocument)
    Application.ScreenRefresh
    MsgBox "There were " & CStr(lngRes) & " different words ", vbOKOnly, "Finished"
End Sub
Function WordCountAndPages(SourceDoc As Word.Document, _
                           Optional ByVal sExcludes = "[the][a][of][is][to][for][by][be][and][are]", _
                           Optional ByVal lmaxwords As Long = 50000) As Long

    ' "[ale][ani][aby][do][od][czy][za][ze][przed][po]" 'excludes for example for polish
    On Error GoTo WordCountAndPages_Error

    Dim NewDoc                    As Word.Document
    Dim TmpRange                  As Word.Range
    Dim aWord                     As Object
    '----------------------------------------
    Dim tmpName                   As String
    Dim strSingleWord             As String

    Dim lngCurrentPage            As Long
    Dim lngPageCount              As Long
    Dim lngWordNum                As Long                  'Number of unique words
    Dim lngttlwds                 As Long                  'Total words in the document
    Dim j                         As Long
    Dim k                         As Long
    Dim w                         As Long
    Dim bTmpFound                 As Boolean               'Temporary flag

    ReDim arrWordList(1 To 1) As String                    'Array to hold unique words
    ReDim arrWordCount(1 To 1) As Long                     'Frequency counter for unique words
    ReDim arrPageW(1 To 1) As String                       'Pages unique words

    lngCurrentPage = 1   'we started to count from a first page to next pages

    With SourceDoc
        If ActiveDocument.FullName <> .FullName Then SourceDoc.Activate    ' because below selection
        Set TmpRange = .Range
        ' document's page count (maybe must refresh)
        lngPageCount = .Content.ComputeStatistics(wdStatisticPages) 'we counted number of pages
    End With
    '--------------
    ' The item in the Words collection includes both the word and the spaces after the word
    ' The Count property for this collection in a document returns the number of items in the main story only.
    ' Also, the Count property includes punctuation and paragraph marks in the total.
    lngttlwds = TmpRange.Words.Count                       '  SourceDoc.Words.Count
    '---------------------
    System.Cursor = wdCursorWait

    Do Until lngCurrentPage > lngPageCount
        If lngCurrentPage = lngPageCount Then
            TmpRange.End = SourceDoc.Range.End             'last page (there won't be a next page)
        Else
            'Find the beginning of the next page
            'Must use the Selection object. The Range.Goto method will not work on a page
            Selection.GoTo wdGoToPage, wdGoToAbsolute, lngCurrentPage + 1  'page, next page
            'Set the end of the range to the point between the pages
            TmpRange.End = Selection.Start
        End If
        '------------------------------------
        For Each aWord In TmpRange.Words
            ' 160 is non breaking space

                strSingleWord = LCase(Replace(Trim(aWord.Text), Chr(160), "")) 'lower character to upper character
                'maybe remove lower case form code, like this: (Replace(Trim(aWord.Text), Chr(160), ""))
                Select Case True
                Case Len(strSingleWord) = 1  'number of characters in single word
                ' if =1 then ignore "a" "&" if = 2 ignore for example: "an" "of" "is" "to" "by" "be"
                Case strSingleWord < "a" Or strSingleWord > "z"    'maybe remove this line form code
                Case InStr(1, sExcludes, "[" & strSingleWord & "]", vbTextCompare)
                Case Else
                    bTmpFound = False
                    For j = 1 To lngWordNum
                        If StrComp(arrWordList(j), strSingleWord, vbTextCompare) = 0 Then
                            arrWordCount(j) = arrWordCount(j) + 1
                            If (arrPageW(j) & "," Like "*," & CStr(lngCurrentPage) & ",*") = False Then
                            arrPageW(j) = arrPageW(j) & "," & CStr(lngCurrentPage)
                            End If
                            bTmpFound = True
                            Exit For
                        End If
                    Next j
                    If Not bTmpFound Then
                        lngWordNum = lngWordNum + 1
                        ReDim Preserve arrWordList(1 To lngWordNum)
                        ReDim Preserve arrWordCount(1 To lngWordNum)
                        ReDim Preserve arrPageW(1 To lngWordNum)
                        arrWordList(lngWordNum) = strSingleWord
                        arrWordCount(lngWordNum) = 1
                        arrPageW(lngWordNum) = arrPageW(lngWordNum) & "," & CStr(lngCurrentPage)
                    End If
                    If lngWordNum > lmaxwords - 1 Then
                        MsgBox "Too many words.", vbOKOnly
                        Exit For
                    End If
            End Select
            lngttlwds = lngttlwds - 1
            StatusBar = "Remaining: " & lngttlwds & ", Unique: " & lngWordNum
        Next aWord
        '------------------------------------
        lngCurrentPage = lngCurrentPage + 1      'move to the next page
        TmpRange.Collapse wdCollapseEnd          'go to the next page
    Loop
    '------------------------------------
    If lngWordNum > 0 Then
        tmpName = SourceDoc.AttachedTemplate.FullName    'output results
        Set NewDoc = Application.Documents.Add(Template:=tmpName, NewTemplate:=False)

        Selection.ParagraphFormat.TabStops.ClearAll
        Application.ScreenUpdating = False
        With Selection
            For j = 1 To lngWordNum
                .TypeText Text:=arrWordList(j) & vbTab & CStr(arrWordCount(j)) & vbTab & Mid(arrPageW(j), 2) & vbNewLine
            Next j
        End With

        Set TmpRange = NewDoc.Range
        TmpRange.ConvertToTable Separator:=wdSeparateByTabs
        With NewDoc.Tables(1)
            .Sort ExcludeHeader:=False, _
                  FieldNumber:="Kolumna 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
                  FieldNumber2:="", _
                  FieldNumber3:="", _
                  CaseSensitive:=False, LanguageID:=wdPolish, IgnoreDiacritics:=False
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
            .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
        End With
    End If
    WordCountAndPages = lngWordNum
    '---------------------
WordCountAndPages_Exit:
    On Error Resume Next
    Set aWord = Nothing
    Set TmpRange = Nothing
    Set NewDoc = Nothing
    System.Cursor = wdCursorNormal
    Application.ScreenUpdating = True

    Exit Function

WordCountAndPages_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura  : " & "WordCountAndPages", vbExclamation
    Resume WordCountAndPages_Exit
End Function

I also need another column with page numbers, where the page number looks like that:
1-3, 5, 6-8. Now the page numbers looks like this: 1,2,3,5,6,7,8. When the
page numbers are consecutive (sequential), beetwen a page numbers I need to
add a hyphen (dashes).

In another column I also need a number of page numbers. For example, when a
some word appear on pages 1,3,5,7, in output results in another column will
be 4.
And the last case: my code search all words in document. I need also search for the keywords.

I have also a some problems with some lines of my code:
strSingleWord < "a" Or strSingleWord > "z" 'fist character of word must
be a letter, this line ignore a special word, like "3w" "4you"
"3ware" "3love" "2day" , and so on...

I have also problem with some words, like: "@SCHL" "m&m", and so
on..., something line of code ignore this words.

I hope so, someone help.

Thanks for your attention!
Regards

[macropod]

Hi markos,

Try something along the lines of:
[VBA]Sub Pages()
Dim oCel As Cell, oRng As Range, StrTmp As String, ArrTmp(), i As Integer, j As Integer, k As Integer
With ActiveDocument.Tables(1).Columns.Last
For Each oCel In .Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
StrTmp = oRng.Text
ReDim ArrTmp(UBound(Split(StrTmp, ",")))
For i = 0 To UBound(Split(StrTmp, ","))
ArrTmp(i) = Split(StrTmp, ",")(i)
Next
For i = 0 To UBound(ArrTmp) - 2
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To UBound(ArrTmp)
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
i = j
End If
Next
oRng.Text = Replace(Replace(Replace(Replace(Join(ArrTmp, ","), ",,", " "), " ,", " "), " ", " "), " ", "-")
Next
End With
Set oRng = Nothing
End Sub[/VBA]

[fumei]

[vba]
Replace(Replace(Replace(Replace( _
Join(ArrTmp, ","), ",,", " "), " ,", " "), " ", " "), " ", "-")
[/vba]

Gotta love it.

[markos97]

Once more thanks macropod for your repley, and thanks for fumei too

But I can't run your code. I must add your code to mine, I don't know. But I don't know how.

This thread is a cross thread.

But If I want to add a link in a forum, I get to: To be able to post links your post count must be 5 or greater... sorry.

[macropod]

Hi markos,

In your code you have a sub named 'Test'. Insert the sub I gave you immediately after this sub, then insert a new line into the 'Test' sub, so that you end up with:
[VBA]Sub Test()
Dim lngRes As Long
lngRes = WordCountAndPages(ThisDocument)
Call Pages ' Modify the page range
Application.ScreenRefresh
MsgBox "There were " & CStr(lngRes) & " different words ", vbOKOnly, "Finished"
End Sub

Sub Pages()
'... include the rest of the 'Pages' sub code here
End Sub

Function WordCountAndPages(SourceDoc As Word.Document,
'... etc[/VBA]

[macropod]

[vba]
Replace(Replace(Replace(Replace( _
Join(ArrTmp, ","), ",,", " "), " ,", " "), " ", " "), " ", "-")
[/vba]

Gotta love it.

Hi Gerry,

Yes, it's not pretty, but it does the job.

[fumei]

It is that Field knowledge/background of yours. All those encapsulated brackets. Gives me a headache. But, very very cute.

I am ALL in favour of things doing the job, regardless of prettiness. Although of course we all prefer things to be elegant. Sometimes it does not work that way. Life can be ugly.

<grin>

[markos97]

Ok, I run your macro. Works, but not so good. When a some words appears on minimum 3 consecutive (sequential) pages, ok good, beetween the numbers of pages, code insert a hyphen, like 1-3, or 6-8. But when a some words appears only on 2 consecutive pages, we get a commas, like 1,2, 4,5, but we also need 1-2, 4-5.

And what the rest my problem, any ideas?

P.S.
Macropod, can you add the link of my thread on social.answears.microsoft, I can’t, because, I havent 5 post yet.

[macropod]

Hi markos,

The retention of commas when the range only spanned two pages was a design decision. Since it's now apparent that's not what you want, try this version of the 'Pages' sub:
[vba]Sub Pages()
Dim oCel As Cell, oRng As Range, StrTmp As String, ArrTmp()
Dim i As Integer, j As Integer, k As Integer, l As Integer
With ActiveDocument.Tables(1).Columns.Last
For Each oCel In .Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
StrTmp = oRng.Text
l = UBound(Split(StrTmp, ","))
ReDim ArrTmp(l)
For i = 0 To l
ArrTmp(i) = Split(StrTmp, ",")(i)
Next
For i = 0 To l - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To l
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","
i = j - 1
End If
Next
oRng.Text = Join(ArrTmp, ",")
With oRng.Find
.MatchWildcards = True
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.Text = "[,]{2,}"
.Replacement.Text = "-"
.Execute Replace:=wdReplaceAll
End With
Next
End With
Set oCel = Nothing: Set oRng = Nothing
End Sub[/vba]
The Find/Replace in the code is to obviate the tortuous nested replace expressions Gerry gagged on ...

Your cross-posts are at: http://social.answers.microsoft.com/...1-0ddc4b50ef7c

[markos97]

[…] was a design decision

A ha … ok.
I thought I make myself clear, when I describing my problem. I hope so I don’t give you an incorrect directions.

The Find/Replace in the code is to obviate the tortuous nested replace expressions Gerry gagged on ...

I have a problem with Find/Replace. When I try to run new version of your code, firstly I get an error:
Run-time error '5941': The requested member of the collection does not exist.

But I think, that before running this macro for the first time, it is necessary to open Word's 'Find' box, enter "[,]{2,}" as the find text, check the 'Use wildcards' option, and perform a single search to get these options into Word's memory. I do it (I hope so correctly), but then I get the next error:

Run-time error '5560': The Find What text contains a Pattern Match expression which is not valid.

Maybe I need a polish match expression of this line:
.Text = “[,]{2,}”
What did you think?

[macropod]

Hi Markos,

For the Polish language, you could probably get it to work by changing:
.Text = "[,]{2,}"
to:
.Text = "[,]{2;}"

Alternatively, for code that's not affected by languange considerations, you could replace everything between the same two Next ... Next expressions with:
[vba]StrTmp = Join(ArrTmp, ",")
Do While InStr(StrTmp, ",,,") > 0
StrTmp = Replace(StrTmp, ",,,", ",,")
Loop
oRng.Text = Replace(StrTmp, ",,", "-")[/vba]

I would also suggest changing the line:
i = j - 1
to:
i = j - 2
That way, if you change your mind about having 1-2,4-5 and decide you want to have 1,2,4,5 after all, all you need to do is comment out or delete the line:
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","

[markos97]

Hi everybody!
Now the code looks better, again, thanks marcopod for you support.

you could replace everything between the same two Next ... Next expressions with

I try it, but incorrectly, maybe show me in which place, and what I have to do, like below:

[vba]
Sub Test()
' rest of the 'Test' sub code here
End Sub

Sub Pages()
'the rest of the 'Pages' sub code here
'...
StrTmp = oRng.Text ‘e.g this line change to...
'in this place add...
'and so on
End Sub

Function WordCountAndPages(SourceDoc As Word.Document,
'...etc
[/vba]

[...]if you change your mind about having 1-2,4-5 and decide you want to have 1,2,4,5[...]

But basicly, right from the beginning, in one column I need the page numbers only with a commas (whatever happend, nothing else metters, we coudn’t care less the numbers are consecutive and/or not consecutive), and in the next column I need the page numbers with a hypens (when the page numbers are consecutive) or with a commas (when the page numbers are not consecutive).

Compare with my thread on a social.answers.microsoft...

[macropod]

Hi Markos,

The 'Pages' sub simply becomes:
[vba]Sub Pages()
Dim oCel As Cell, oRng As Range, StrTmp As String, ArrTmp()
Dim i As Integer, j As Integer, k As Integer, l As Integer
With ActiveDocument.Tables(1).Columns.Last
For Each oCel In .Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
StrTmp = oRng.Text
l = UBound(Split(StrTmp, ","))
ReDim ArrTmp(l)
For i = 0 To l
ArrTmp(i) = Split(StrTmp, ",")(i)
Next
For i = 0 To l - 1
If IsNumeric(ArrTmp(i)) Then
k = 2
For j = i + 2 To l
If CInt(ArrTmp(i) + k) <> CInt(ArrTmp(j)) Then Exit For
ArrTmp(j - 1) = ""
k = k + 1
Next
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","
i = j - 2
End If
Next
StrTmp = Join(ArrTmp, ",")
Do While InStr(StrTmp, ",,,") > 0
StrTmp = Replace(StrTmp, ",,,", ",,")
Loop
oRng.Text = Replace(StrTmp, ",,", "-")
Next
End With
Set oCel = Nothing: Set oRng = Nothing
End Sub[/vba]
With this code, if your page numbers start out as 1,2,4,5,6,8,10,11,13,14,15,16,17,19 you will end up with 1-2,4-6,8,10-11,13-17,19. However, if you comment out or delete the line:
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","
you will end up with 1,2,4-6,8,10,11,13-17,19.

[markos97]

Yeah, this is it! Thank you macropod.
Starting today, for a period of time, I will be written only on a social.forum.microsoft, we will see how Andreas code work (now I have some trouble with his code). I think, that Andreas solution is more effective (I mean store the result immediately in Excel, and very easiest in opposite to "my" very long code). But once again, thanks for you.
If something goes wrong, I call you back.
See you later. Maybe you visit once again a social.forum.
Regards

[macropod]

Hi markos,
Re:

In another column I also need a number of page numbers. For example, when a some word appear on pages 1,3,5,7, in output results in another column will be 4.

You can get that by changing the following line in your original WordCountAndPages function from:

.TypeText Text:=arrWordList(j) & vbTab & CStr(arrWordCount(j)) & vbTab & Mid(arrPageW(j), 2) & vbNewLine

to:

.TypeText Text:=arrWordList(j) & vbTab & CStr(arrWordCount(j)) & vbTab & _
UBound(Split(Mid(arrPageW(j), 2), ",")) & vbTab & Mid(arrPageW(j), 2) & vbNewLine

With this simple change you will gate a 4-column table with the count in column 3.
As for:

And the last case: my code search all words in document. I need also search for the keywords.

You would need to supply the list of keywords - and you'd need to say what has to be done with the search results.

[markos97]

Hi, and thanks again for your help.

You can get that by changing the following line in your original WordCountAndPages function from […] to […].

Ok, I change it, but... something's wrong in results. Wacht out: in document we have e.g. following word "cat" which appear on page number 1, and page number 3, and on page number 2 we have a "dog".
And in column 3 in results we get only "1" number of pages, but the "cat" appears on 2 pages (page nr 1, and 3)! In turn, in column 3 for a dog we get 0 (zero), but the dog appear on page number 2 and will be 1 (appear on one page)!

And the next problem, next example: If "cat" appear on pages which are consecutive 1,2,3, in results we get "2" while the "cat" appear on 3 pages (1,2,3), not 2 pages! I think it happens, because in results on column 4 we get page numbers with a hypens 1-3. Something is wrong.

11-02-2010, 07:20 PM, macropod wrote:

That way, if you change your mind about having 1-2,4-5 and decide you want to have 1,2,4,5 after all, all you need to do is comment out or delete the line:
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","

11-03-2010, 07:41 PM, macropod wrote, again:

With this code, if your page numbers start out as 1,2,4,5,6,8,10,11,13,14,15,16,17,19 you will end up with 1-2,4-6,8,10-11,13-17,19. However, if you comment out or delete the line:
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","
you will end up with 1,2,4-6,8,10,11,13-17,19.

[1,2,4-6,8,10,11,13-17,19, what? You probably mistake!?, do you mean, if I comment out or delete above line I have to get: 1,2,4,5,6,8,10,11,13,14,15,16,17,19 (only page numbers with commas, not with a hypens ...4-6...13-17..., but never mind]

Macropod, I need in the end as 5-column (maybe I remember you shortly, once more: Word, FQ, Commas page numbers, Commas or/and hyphens page numbers, and the Number of page numbers).
Comment out or delete the line:

If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","

is good idea to get the page numbers only with a commas, but I need also the another column to a page numbers with a hyphens or/and commas.

Maybe to do it, we need something like call statement, like:

 
Sub Test() 
    Dim lngRes                    As Long 
    lngRes = WordCountAndPages(ThisDocument) 
    Call Pages1 ' Modify the page range
    Call Pages2
    Application.ScreenRefresh 
    MsgBox "There were " & CStr(lngRes) & " different words ", vbOKOnly, "Finished" 
End Sub 
 
Sub Pages1 () 'page numbers with comma and/or hyphens
'the rest of code
If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & ","
'the rest of code
End Sub
 
Sub Pages2 () 'page numbers with a comma
'the rest of code
k = k + 1 
                Next 
                'If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & "," 
'above line I comment out, that how you advise me, to get page numbers only with comma
                i = j - 2 
            End If
'the rest of code
End Sub
 
Function WordCountAndPages(SourceDoc As Word.Document, 
     '... etc

You would need to supply the list of keywords

Ok, something like: array = ("dog", "cat", "bird", and so on)
maybe compare with below link
http://microsoft-personal-applicatio...3/Default.aspx

and you'd need to say what has to be done with the search results.

I’m not understand, what to be done with the search results? Simply, store them in column 1 in results document, like now my code do it. Oh, I think I know what you mean. Macropod, I don’t know how to resolve this problem from a technical side. But I think that one code, will be search the all words or only the keywords (if user comment out some line of code, then will be search for all words, or only a keywords), or maybe we need two versions of code: one code search for all words in document, and second code search only for a keywords, and the user decide which code to use, which code to need, I don’t know which solution is better, only the programers like you, know that.

Sorry, but I think that I waste your time macropod. I think intensively about Andreas solution on social.answears.microsoft. I think, that this solution is a better, becasue, the user can make to sort the results immediately in excel (in word, we can’t sort the results). Using "my" code, we have to copy, and paste the results to excel, and in the end sort them, if we want. I’m intresting your solution, but maybe help also on social.answears? Andreas help me, but he don’t close my case. I think that I know how to get the number of page numbers in Andreas solution, but to do this I need someone help to get in Andreas solution column results (column "D") with page numbers only with a commas.

Thanks for attention, and sorry for my long describe

Regards

[macropod]

Hi Markos,

in document we have e.g. following word "cat" which appear on page number 1, and page number 3, and on page number 2 we have a "dog".
And in column 3 in results we get only "1" number of pages, but the "cat" appears on 2 pages (page nr 1, and 3)! In turn, in column 3 for a dog we get 0 (zero), but the dog appear on page number 2 and will be 1 (appear on one page)!

And the next problem, next example: If "cat" appear on pages which are consecutive 1,2,3, in results we get "2" while the "cat" appear on 3 pages (1,2,3), not 2 pages! I think it happens, because in results on column 4 we get page numbers with a hypens 1-3. Something is wrong.

In the code I gave you in my last post, change:
UBound(Split(Mid(arrPageW(j), 2), ","))
to:
UBound(Split(Mid(arrPageW(j), 2), ",")) + 1
and everything should be OK.

or maybe we need two versions of code: one code search for all words in document, and second code search only for a keywords, and the user decide which code to use, which code to need, I don’t know which solution is better

Yes, you will need two versions of the code but, as to which is better, that depends on the user's needs!

I think intensively about Andreas solution on social.answears.microsoft. I think, that this solution is a better, becasue, the user can make to sort the results immediately in excel (in word, we can’t sort the results).

Word can sort tables (which is what the code produces) quite easily!

[markos97]

Yeah! That’s right. Now works good. In your previous post, you omitted +1 in below line of code, but now, it’s okay. Pretty good.

  UBound(Split(Mid(arrPageW(j), 2), ",")) + 1

you will need two versions of the code

Maybye you know how to do it?

Macropod, I think we have the most of my problem. But still we haven’t a column with a page numbers only with a commas. Is it possible to get them in another column?

Once more thanks for your support. I’m impressed for your knowledge, awsome!
Regards

[macropod]

Hi markos,

Maybye you know how to do it?

Yes, but VBA Express isn't simply a free coding service. We expect users to make an effort to do at least some of their own coding. We're here to help when you get stuck. In any event, there are plenty of examples of code for this available on the web - you just need to do some searching.

I think we have the most of my problem. But still we haven’t a column with a page numbers only with a commas. Is it possible to get them in another column?

I don't understand what you're saying. What you should now be getting is the table with the word list, word count, page count and page ranges. What else do you want?

[markos97]

Hi everyone!

Yes, but VBA Express isn't simply a free coding service. We expect users to make an effort[...]

Ok, understand. But from the beginning, in any kind of forum, I know about it. Every time, I try oneself to find a solution, or, if I’m able to, I try to do it, oneself. But many things is to difficult. I’m only the technical user, and from time to time, I do something oneself.Come back
to my problem, now I have the most what I need. In results, I get a 5 column. I
add using a call statement, new column with page numbers separated only with a
comma. Also added in results a bolded column headers, I do it based on below
link: http://www.avdf.com/aug98/art_vb006.html To stay headers in top of table results, I change False property to True in line, which sorted the header results.

Sub Test()
      'beginning of code
      Call Pages1
      Call Pages2
      'end of code
  End Sub
  Sub Pages1()
  'rest of code
  End Sub
  Sub Pages2()
  'beginning of code
                  'If CInt(ArrTmp(i) + 1) = ArrTmp(i + 1) Then ArrTmp(i) = ArrTmp(i) & "," 'this line comment out
  'end of code
  End Sub
  Function WordCountAndPages(SourceDoc As Word.Document, _
  'beginning of code, no changes, no added
  Selection.ParagraphFormat.TabStops.ClearAll
          Application.ScreenUpdating = False
          With Selection 'below add bolded column headers
              Selection.Font.Bold = wdToggle
  Selection.TypeText Text:="Words" & vbTab &  "Fq" & vbTab & "NrOfPageNumbers" & vbTab &  "CPageNumbers" & vbTab & "H/C/HCPageNumbers" & vbCrLf
  Selection.Font.Bold = wdToggle
              For j = 1 To lngWordNum
                  .TypeText Text:=arrWordList(j) & vbTab & CStr(arrWordCount(j)) & vbTab & _
  UBound(Split(Mid(arrPageW(j), 2), ",")) + 1 &  vbTab & Mid(arrPageW(j), 2) & vbTab & Mid(arrPageW(j), 2)  & vbNewLine ‘add Mid(arrPageW(j), 2)
  'the following code
  .Sort ExcludeHeader:=True 'False change to True
  'the end of code function

I the end, I think also how to store the result immediately in excel (familiar as Andreas Killer code to do it). Or maybe simpliest, how to copy the results ang paste to excel, and in the end close the results Word document. I’m also intresting how will be looks the code indexing only a keywords.

Thanks for your attention, and your time.

Regards