pulling select table rows based on content, pasting to new word doc (or Excel)

[Ker_01]

I've done a bit of VBA in Excel, but have less experience with the Word
object model.

I was just asked to help a colleague with an 'urgent' project involving
opening every .doc file in a target directory, checking each row in each
table to identify rows that have four columns, then for any of those that
have "V" in the second column, copy the row plus the document name into a
new file (either Word or Excel should work).

Can anyone point me to code snippets for cycling through cells within a row,
table rows, and entire tables?

I assume the endcode will be a syntax appropriate versions of the following,
but if I have similar code it will be faster to adapt it than try to do it
all from scratch while learning the object model.

Many thanks,
Keith

for each Document in MyDirectoryTree
Document.open

Set tempdocument = ActiveDocument
For each Table in Document
For each Row in Table
If Row.cells.count = 4 then
if Rows.cell(2) = "V" then

a= ActiveDocument.name
b=ActiveDocument.Table(?).Row(?).Cell(1)
c=ActiveDocument.Table(?).Row(?).Cell(2)
d=ActiveDocument.Table(?).Row(?).Cell(3)
e=ActiveDocument.Table(?).Row(?).Cell(4)

OutputDocument.Activate
OutputDocument.Table1.addrow
OutputDocument.Table1.cell(1) = a
OutputDocument.Table1.cell(1) = b
OutputDocument.Table1.cell(1) = c
OutputDocument.Table1.cell(1) = d
OutputDocument.Table1.cell(1) = e

TempDocument.activate
endif
endif
endif
endif

Document.close
Next

 

[Doug Robbins - Word MVP]

See the article "Find & ReplaceAll on a batch of documents in the same
folder" at:

http://www.word.mvps.org/FAQs/MacrosVBA/BatchFR.htm

Modify the code in that article to make use of

Dim atable As Table
Dim arow As Row
Dim arange As Range

For Each atable In myDoc.Tables
For Each arow In atable.Rows
If arow.Cells.Count = 4 Then
Set arange = arow.Cells(2).Range
arange.End = arange.End - 1
If arange.Text = "V" Then
arow.Range.Copy 'the row will now be on the clipboard
End If
End If
Next arow
Next atable



--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Ker_01]

Doug- thank you for the quick reply.

I'm well on the way; now I've run into an error message - "Runtime error
5991: Cannot access individual rows in this collection because the table has
vertically merged cells". The particular table/cell it crashes on is /not/
one of my target rows, I'm tempted to just add an "On Error Resume Next".
However, these documents are in an uncontrolled environment, and there is a
(slight) possibility that someone could have merged cells across two rows
while putting in target data, and I don't want to miss it, so I plan to use
an errorhandler to deal with this particular error.

I've pasted my current code below. In the errorhandler, I want to activate
the row causing the error so the user can see it onscreen, but my syntax for
selecting that row isn't working (Runtime error 438: Object doesn't support
this property or method).
Thanks for any additional assistance,
Keith

'-----------------------------------------------------------------------------------------------
Sub CycleFiles()

On Error GoTo ErrorHandler

Dim atable As Table
Dim arow As Row
Dim arange As Range
Dim TempDoc As Document
Dim RootDoc As Document

Set RootDoc = Word.ActiveDocument

PathToUse = "C:\KimTest\"

myfile = Dir$(PathToUse & "*.doc")

While myfile <> ""

'Open document
Set TempDoc = Documents.Open(PathToUse & myfile)

For Each atable In TempDoc.Tables
For Each arow In atable.Rows
If arow.Cells.Count = 4 Then
Set arange = arow.Cells(2).Range
arange.End = arange.End - 1
If UCase(arange.Text) = "V" Then
arow.Range.Copy 'the row will now be on the clipboard
RootDoc.Activate
RootDoc.Tables(1).Rows.Add
RDTRC = RootDoc.Tables(1).Rows.Count
RootDoc.Tables(1).Rows(RDTRC).Cells(2).Select
Selection.Paste
RootDoc.Tables(1).Rows(RDTRC).Cells(1).Range.Text =
myfile.Name
TempDoc.Activate
End If
End If
Next arow
Next atable

'Close the modified document after saving changes
TempDoc.Close (False)

'Next file in folder
myfile = Dir$()

Wend

ErrorHandler:
Select Case Err.Number
Case 5991 ' "Vertical Merged Cells" error.
With TempDoc
.Activate
.atable.Rows(arow).Select '*** error 438 here ***
MsgBox "The macro has found a vertically merged cell." & _
"Please visually check the cell to ensure that " & _
"this is not a row with critical data. If it is, " &
_
"open this source file manually, select the row, " &
_
"unmerge it, then re-run this macro.", , "Error
reading merged cells"
End With
Case Else
' do nothing for now?
End Select
Resume

End Sub

 

[Doug Robbins - Word MVP]

I am guessing that stepping through a collection like that, when an error
occurs, Word does not retain information on where it was in the collection.
Try declaring a couple of variables to be used as counters and incremented
as you step through the collection.


--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

 

[Ker_01]

I added a table and row counter, and that helped me obtain additional
information (related to the original error which prompted my error
handling). It still crashes in the error handler (5991: Can't access
individual rows in this collection because the table has vertically merged
cells), but I was able to use the table and row counters to look for the
offending row. There isn't any obvious merging, but there is a text form
field (regular text, unlimited length, bookmark area, fill-in enabled) in
table 2, row 1, column 1. As far as I can tell, nothing is protected.
Interestingly, that table shows onscreen as a 2x2 table so I wouldn't have
expected my code to even stop there, since I'm screening for rows with 4
columns.

My counters are not very elegant (I wasn't sure how to derive the row and
table number directly from atable and arow), but here is the current version
of the code.

Other than splitting cells, is there any type of "unmerge" command in Word?
I close the source documents without saving, so if the problem is merged
cells, perhaps there is a way to unmerge each table before processing, then
scan the table?

Thank you for any assistance or advice,
Keith


Sub CycleFiles()

Dim atable As Table
Dim arow As Row
Dim arange As Range
Dim TempDoc As Document
Dim RootDoc As Document
Dim NumTable as Integer
Dim NumRow as Integer

Set RootDoc = Word.ActiveDocument

PathToUse = "C:\KimTest\"

myfile = Dir$(PathToUse & "*.doc")

While myfile <> ""

'Open document
Set TempDoc = Documents.Open(PathToUse & myfile)

On Error GoTo ErrorHandler

NumTable = 1
For Each atable In TempDoc.Tables
NumRow = 1
For Each arow In atable.Rows
If arow.Cells.Count = 4 Then
Set arange = arow.Cells(2).Range
arange.End = arange.End - 1
'MsgBox Len(arange)
If UCase(arange.Text) = "V" Then
arow.Range.Copy 'the row will now be on the clipboard
RootDoc.Activate
RootDoc.Tables(1).Rows.Add
RDTRC = RootDoc.Tables(1).Rows.Count
RootDoc.Tables(1).Rows(RDTRC).Cells(2).Select
Selection.Paste
RootDoc.Tables(1).Rows(RDTRC).Cells(1).Range.Text =
myfile.Name
TempDoc.Activate
End If
End If
NumRow = NumRow + 1
Next arow
NumTable = NumTable + 1
Next atable

'Close the modified document after saving changes
TempDoc.Close (False)

'Next file in folder
myfile = Dir$()

Wend

ErrorHandler:
Select Case Err.Number
Case 5991 ' "Vertical Merged Cells" error.
TempDoc.Activate
TempDoc.Tables(NumTable).Rows(NumRow).Select
'Selection.SetRange Start:=Selection.Rows(arow).Range.Start,
End:=Selection.End
MsgBox "The macro has found a vertically merged cell." & _
"Please visually check the cell to ensure that " & _
"this is not a row with critical data. If it is, " & _
"open this source file manually, select the row, " & _
"unmerge it, then re-run this macro." & _
Chr(13) & Chr(13) & _
"This macro will continue to process the remaining
files", , "Error reading merged cells"
On Error Resume Next
Case Else
' do nothing for now?
End Select
Resume

End Sub