Hi! I'm new to the forum
Sort of an advanced question, I think?
THE FOLLOWING WORKS
But
it's slow. It takes about a half hour to work through an 84 page document
Maybe my biggest question is
state management
In Excel, I can turn off printer communication, formula calculation, etc. to add a ton of speed.
None of that appears to be a thing for Word VBA - except for maybe screen updating.
(And that doesn't appear to work - I can still watch the macro's progress before Word locks up?)
My second (less important) question is
is there a simpler approach?
(A lot of my first attempts included a few things that wouldn't work for manipulating a varied-column-count table.)
I have a lot of experience with Excel VBA - but hardly any with Microsoft Word VBA.
So maybe I'm taking the wrong approach? Thinking in tables instead of strings?
Here's the situation:
I'm using Acrobat Pro to export a PDF into Word ...
so I can paste it into Excel and read/manipulate the numbers.
The exporter (or the PDF itself?) has a few flaws:
It doesn't create one, uniform table (same number of columns, same width, all rows) ... it sort of barfs it all into row after row - with diverse (apparently arbitrary?) column counts and widths.
Worse, the exporter uses tab stops and alignment to format the table from there - it looks great (like the PDF) but cannot be read as data.
(Exporting direct to Excel is worse - it just skips the tab stops and alignment part altogether. Without that formatting, I have even fewer clues to tell what information corresponds to what column, etc..)
So here's what I have so far
The code below uses delimiters to:
Replace each tab character with the associated tab stop's apparent page position
Add the apparent right margin's page position to right-justified cells
What it creates, I can paste into Excel and use another (much faster) macro to redistribute data across columns - i.e. 1.42 inches to 1.95 inches = destination column 3, etc.
Code:
Option Explicit
Private Sub wordMacro_start()
Dim xcount As Long
Dim xcol As Long, xrow As Long, xlng As Long
Dim xstr As String
Dim xdbl As Double
'Tracks macro's speed
Dim startTime As Date
startTime = Now()
Application.ScreenUpdating = False
Dim tbl As Table
Dim tbs As TabStop
Dim rng As Range
'Loops through every table
For Each tbl In ActiveDocument.Tables
xcount = xcount + 1
Debug.Print xcount 'So I can read progress
DoEvents 'So I have windows to pause execution
'Loops through every column
xcol = 1
Do
If xcol > tbl.Columns.Count Then Exit Do
'Loops through every row
xrow = 1
Do
If xrow > tbl.Rows.Count Then Exit Do
'Skips when cell address doesn't exist within the table
Set rng = Nothing
On Error Resume Next
Set rng = tbl.Cell(xrow, xcol).Range
On Error GoTo 0
If Not rng Is Nothing Then
'Tab stops and tab characters
'Loops through every tab stop within the cell
For Each tbs In rng.Paragraphs.TabStops
'Gets starting position of next tab character
xlng = InStr(1, rng.Text, vbTab)
If xlng = 0 Then Exit For
'Gets position of the tab stop + previous cell widths in the row
'Equals page position, sorta
xstr = rng.Text
xstr = Left(xstr, xlng - 1) & _
"{" & (pullRecursive_width(tbl, xrow, xcol) - _
PointsToInches(tbl.Cell(xrow, xcol).Width)) + _
PointsToInches(tbs.Position) _
& "}" & _
Right(xstr, Len(xstr) - xlng)
'Replaces the tab character with the position number
rng.Text = xstr
Next tbs
'Alignment
'Fortunately, cells with right alignments don't generate with tab characters
'If alignment is right
If tbl.Cell(xrow, xcol).Range.Paragraphs.Alignment = wdAlignParagraphRight Then
'If cell didn't generate as 'empty'
If tbl.Cell(xrow, xcol).Range.Text <> Chr(13) & _
Chr(7) Then
'Gets this + all previous cell widths in the row
'Equals page position of the right margin of the cell
xdbl = pullRecursive_width(tbl, xrow, xcol)
xstr = "{" & _
xdbl & "}" & _
rng.Text
'Adds the position to the cell width
rng.Text = xstr
End If
End If
End If
xrow = xrow + 1
Loop
xcol = xcol + 1
Loop
Next tbl
'Takes forever, sometimes start it and leave - so I have the macro save on finish
ActiveDocument.Save
'Describes macro's speed
MsgBox "(" & Format(Now() - startTime, "Nn \mi\nute\s, Ss \se\co\n\d\s") & ")"
Application.ScreenUpdating = True
End Sub
Private Function pullRecursive_width(sent_table As Table, _
xrow As Long, _
xcol As Long) As Double
'Starts with current cell's width
pullRecursive_width = PointsToInches(sent_table.Cell(xrow, xcol).Width)
'If current cell is first cell, returns
If xcol <= 1 Then Exit Function
'If current cell isn't first cell, adds previous cell's width
pullRecursive_width = pullRecursive_width + _
pullRecursive_width(sent_table, xrow, xcol - 1)
End Function