VBA - Optimizing locating index of first row on each page of Word Table via. Excel - excel

Question

I have a bunch of word documents that each contain a single table, some of which hold an exorbitant amount of data (20,000+ rows perhaps) and hence can stretch over hundreds of pages long.
With that being said, I found a VBA word macro that can display all row indices that start every page. For example, the macro will display 100 integers for a table that stretches for 100 pages. This is exactly what I need but for various reasons, the macro runs very slow. Furthermore, it runs even slower when I adapted the code and embedded it into an excel macro (to use on a word object).
So my question is - can this macro be somehow optimized? I suppose the looping is causing the problem. Many thanks for your input!
Sub TableRowData()
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
While rownum < ActiveDocument.Tables(1).Rows.Count
Set rw = rw.Next
rownum = rownum + 1
Set rg = rw.Range
rg.Collapse wdCollapseStart
If rg.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
End Sub

Answer 1

Try something based on:
Sub TableRowData()
Dim Doc As Document, Rng As Range, Data() As Long, i As Long, j As Long, p As Long, r As Long, x As Long
Set Doc = ActiveDocument
With Doc
With .Tables(1).Range
i = .Cells(1).Range.Characters.First.Information(wdActiveEndAdjustedPageNumber)
j = .Cells(.Cells.Count).Range.Characters.Last.Information(wdActiveEndAdjustedPageNumber)
ReDim Data(3, j - i)
For p = i To j
Set Rng = Doc.Range.GoTo(What:=wdGoToPage, Name:=p)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
r = Rng.Cells(1).RowIndex
x = p - i: Data(1, x) = x: Data(2, x) = p: Data(3, x) = r
Next
End With
End With
End Sub

Answer 2

Processing tables row by row is notoriously slow and there is little you can do to speed things up.
One thing that will help is to turn off screen updating. At the start of your routine add Application.ScreenUpdating = False and at the end Application.ScreenUpdating = True.
The other thing you can experiment with is using a For Each loop. There is some disagreement as to whether or not this method is faster. Having a large table to process will give you a pretty good idea of which is the faster method, but don't expect miracles. Whichever method you adopt you are going to need patience.
Sub TableRowData()
Application.ScreenUpdating = False
'define meaningful names to use for array's first dimension
Const pgnum = 1
Const startrow = 2
Const endrow = 3
Dim data() As Long ' array to hold data
Dim rw As Row ' current row of table
Dim rownum As Long ' the index of rw in table's rows
Dim datarow As Long ' current value of array's second dimension
'Dim rg As Range ' a range object for finding the page where rw starts
'initialization
ReDim data(3, 1)
Set rw = ActiveDocument.Tables(1).Rows(1)
rownum = 1
datarow = 1
'store the page number and row number for the first row of the table
Set rg = rw.Range
rg.Collapse wdCollapseStart
data(pgnum, datarow) = rg.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
'Step through the remaining rows of the table.
'Each time the page number changes, store the preceding row as the
'last row on the previous page; then expand the array and store the
'page number and row number for the new row.
'While rownum < ActiveDocument.Tables(1).Rows.Count
For Each rw In ActiveDocument.Tables(1).Rows
'Set rw = rw.Next
rownum = rownum + 1
'Set rg = rw.Range
'rg.Collapse wdCollapseStart
If rw.Range.Information(wdActiveEndAdjustedPageNumber) > data(pgnum, datarow) Then
data(endrow, datarow) = rownum - 1
ReDim Preserve data(3, datarow + 1)
datarow = datarow + 1
data(pgnum, datarow) = rw.Range.Information(wdActiveEndAdjustedPageNumber)
data(startrow, datarow) = rownum
End If
Next rw
'Wend
'finish up with the last row of the table
data(endrow, datarow) = rownum
Dim msg As String
Dim i As Long
For i = 1 To UBound(data, 2)
msg = msg & data(startrow, i) & vbCr
Next i
MsgBox msg
Application.ScreenUpdating = True
End Sub

Answer 3

How about looping through the pages and getting the row number?
Would that work?
Dim doc As Document
Dim rng As Range
Dim pg As Long
Application.ScreenUpdating = False
Set doc = ThisDocument
For pg = 1 To doc.Range.Information(wdNumberOfPagesInDocument)
Set rng = doc.GoTo(wdGoToPage, wdGoToAbsolute, pg)
Debug.Print rng.Information(wdEndOfRangeRowNumber)
Next pg