Wordcount in tables

Thread view:

Enable EMail Alerts

Start New Thread

Thread rating:

John Svendsen - 31 Oct 2007 13:54 GMT

Hi all:
I've written a macro to count non-space characters and words specifically
for Word tables; but it seems that computestatistics does not work for
tables? Could've I done something wrong or is this so? Please see code
below.
TIA, js

--------------------------------------------------------------
Sub Z_TABLEComputeStatistics()
Dim tS, tE, TotNSChar As Long, TotNSCharS As Long, TotWrd As Long, TotWrdS
As Long
Dim NTabMax As Long, NTab As Long, NRow As Long, NRowMax As Long, NCol As
Long, NColMax As Long
Dim R As Range, Txt As String
tS = Time: TotNSChar = 0: TotNSCharS = 0: TotWrd = 0: TotWrdS = 0
NTabMax = ActiveDocument.Tables.Count
For NTab = 1 To NTabMax
NColMax = ActiveDocument.Tables(NTab).Columns.Count
NRowMax = ActiveDocument.Tables(NTab).Rows.Count
For NCol = NColMax To NColMax
For NRow = 1 To NRowMax
ActiveDocument.Tables(NTab).Cell(NRow, NCol).Select
Set R = ActiveDocument.Tables(NTab).Cell(NRow, NCol).Range
Txt = Left(R.Text, Len(R) - 2)
Txt = Replace(Txt, " ", ""): Txt = Replace(Txt, Chr(160), "")
If ActiveDocument.Tables(NTab).Cell(NRow,
NCol).Shading.BackgroundPatternColor = wdColorAutomatic And _
ActiveDocument.Tables(NTab).Cell(NRow,
NCol).Shading.ForegroundPatternColor = wdColorAutomatic Then
'If Selection.Shading.BackgroundPatternColor = wdColorAutomatic Then
TotWrd = TotWrd + R.ComputeStatistics(Statistic:=wdStatisticWords)
'*DEBUG* MsgBox ActiveDocument.Tables(NTab).Cell(NRow,
NCol).Range.ComputeStatistics(wdStatisticWords)
TotNSChar = TotNSChar + Len(Txt)
Else
TotWrdS = TotWrdS + R.ComputeStatistics(Statistic:=wdStatisticWords)
'*DEBUG* MsgBox ActiveDocument.Tables(NTab).Cell(NRow,
NCol).Range.ComputeStatistics(wdStatisticWords)
TotNSCharS = TotNSCharS + Len(Txt)
End If
Next NRow
Next NCol
Next NTab
tE = Time
MsgBox ("No-space Character Count of Last Column In Tables:" & vbCrLf & _
"Total NSCharacters in NON-shaded Cells =" & TotNSChar & vbCrLf & _
"Total NSCharacters in SHADED Cells =" & TotNSCharS & vbCrLf & _
"Grand-Total NSCharacters in Last Column=" & TotNSChar + TotNSCharS)
& vbCrLf & vbCrLf & _
("Word Count of Last Column In Tables:" & vbCrLf & _
"Total Words in NON-shaded Cells =" & TotWrd & vbCrLf & _
"Total Words in SHADED Cells =" & TotWrdS & vbCrLf & _
"Grand-Total Words in Last Column=" & TotWrd + TotWrdS)
MsgBox "Start=" & tS & " | End=" & tE & " | Lap=" & Format(tE - tS,
"hh:mm:ss")
End Sub

Reply to this Message

Helmut Weber - 31 Oct 2007 17:11 GMT

Hi John,

apart from that you posted too much code
instead of clearing it before
from all that was tested and is working,
it is working alright here and now.

No problem with something like:

Sub Test04()
With ActiveDocument.Tables(1).Range
MsgBox .ComputeStatistics(wdStatisticWords)
End With
End Sub

Signature

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

Reply to this Message

John Svendsen - 31 Oct 2007 17:27 GMT

Hi Helmut: thanks for your reply.

Please try:

Sub Test04()
With ActiveDocument.Tables(1).Cell(1, 1).Range
MsgBox .ComputeStatistics(wdStatisticWords)
End With
End Sub

Tks, JS

> Hi John,
>
[quoted text clipped - 10 lines]
> End With
> End Sub

Reply to this Message

Helmut Weber - 31 Oct 2007 17:43 GMT

Hi John,

Text in cell(1,1) is "Red Brown"

>Sub Test04()
>With ActiveDocument.Tables(1).Cell(1, 1).Range
>MsgBox .ComputeStatistics(wdStatisticWords)
>End With
>End Sub

returns 0 (zero) :-(

But as selection is often faster in tables anyway,
you may google for my decent name and "selection table speed",
or similar, if you like.

I'd recommend something like that:

Sub Test04a()
With ActiveDocument.Tables(1).Cell(1, 1).Range
.Select
Selection.End = Selection.End - 1
MsgBox Selection.Range.ComputeStatistics(wdStatisticWords) ' 2
End With
End Sub

HTH

Signature

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

Reply to this Message

John Svendsen - 11 Nov 2007 13:06 GMT

Hi Helmut,
Please excuse my belated reply - thanks for your suggestion, it works like a
charm :)
Danke, JS

> Hi John,
>
[quoted text clipped - 23 lines]
>
> HTH

Reply to this Message

Helmut Weber - 11 Nov 2007 13:20 GMT

accepted,

thx for the feedback

Signature

Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"

Reply to this Message

John Svendsen - 31 Oct 2007 17:28 GMT

P.S. I'm using Office 2003 on XP Home :)

> Hi John,
>
[quoted text clipped - 10 lines]
> End With
> End Sub

Reply to this Message