copying specific rows

[Kilroy]

17093

My checklist are upwards of 75 pages at times. I'm wondering if it's possible to write a code that will copy the first 2 rows of the checklist and then any row that has an "N" in column 4 and populate into a new document. I generally use "Y", "N" or "N/A". I just need the rows with "N" only and the first 2 rows. I don't know where to start. Any help appreciated.

[gmaxey]

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim lngIndex As Long
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
Set oTbl = oDoc.Tables(1)
For lngIndex = oTbl.Rows.Count To 3 Step -1
If fcnGetCellText(oTbl.Cell(lngIndex, 4)) <> "N" Then
oTbl.Rows(lngIndex).Delete
End If
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Function fcnGetCellText(oCell As Cell) As String
'Replace the end of cell marker with a null string.
fcnGetCellText = Replace(oCell.Range.Text, ChrW(13) & ChrW(7), vbNullString)
lbl_Exit:
Exit Function
End Function

[Kilroy]

Greg that works great for the example I gave. However just like last time my example didn't cover different scenarios. Sorry. I'm adding another attachment that more reflects my checklists. Sometimes the cells in the first column are merged.

[Kilroy]

17094

Greg that works great for the example I gave. However just like last time my example didn't cover different scenarios. Sorry. I'm adding another attachment that more reflects my checklists. Sometimes the cells in the first column are merged.

[gmaxey]

Kilroy,

No one likes to have their time wasted answering poorly defined questions. When you post a question please be sure that it is the question you really want answered in the first place.


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
Set oTbl = oDoc.Tables(1)
For Each oCell In oTbl.Range.Cells
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then
oCell.Select
Selection.Rows.Delete
End If
End If
End If
Next
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Thanks Greg. Like usual your code is perfect.

[Kilroy]

Greg wrote this code that is perfect for what I asked for. However I've come across a scenario where there is more than one table in my check list. I've tried changing the "Set oTbl = oDoc.Tables(1)" to (1,5), I've tried copying and pasting the same code 5 times and changing to "Set oTbl = oDoc.Tables(2)then (3) and so on" I can't get it to work. Is there a way to get it recognize each of the tables no matter how many there are?




Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
Set oTbl = oDoc.Tables(1)
For Each oCell In oTbl.Range.Cells
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then
oCell.Select
Selection.Rows.Delete
End If
End If
End If
Next
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Try replacing

set oTbl = oDoc.Tables(1)

with a


For Each oTbl in oDoc.Tables

Next oTbl

loop

[Kilroy]

I'm getting a "Loop without do" error.


Sub NotAdequate()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
For Each oTbl In oDoc.Tables
Next oTbl
Loop
For Each oCell In oTbl.Range.Cells
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then
oCell.Select
Selection.Rows.Delete
End If
End If
End If
Next
lbl_Exit:
Exit Sub
End Sub

[gmaxey]

Yes you would. I'm pecking this out on a cell. It seems to me that you g
have seen enough code to know that you need to put something inside that for each loop and get rid of the loop not paired with a do

[Kilroy]

OK the best I can understand is below. Its getting hung up on the end sub saying "compile error without next." give me a hint Greg.


Sub NotAdequate()
'A lame attempt to modify a macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
For Each oTbl In oDoc.Tables
Next oTbl
For Each oCell In oTbl.Range.Cells
Do
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then
oCell.Select
Selection.Rows.Delete
End If
End If
End If
Loop
Exit Sub
End Sub

[gmaxey]

KillRoy,

Instead of getting rid of the Loop like I advised, you added a Do.

I also suggested that you have seen enough code that you should know that unless there is something inside a For Each .... Next code segment then it is pretty useless.

Does this make much sense?

For Each oTbl In oDoc.Tables
Next oTbl

You were already looking at a functional example of a For Each ... Next loop. After all, it is one of those that works perfectly to loops through each cell in a table. All you had to do was apply that concept to each table in the document.



Sub KilRoysLackOfReasonableEffortFixed()
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
ActiveDocument.Range.Copy
Set oDoc = Documents.Add
oDoc.Range.Paste
For Each oTbl In oDoc.Tables
For Each oCell In oTbl.Range.Cells
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then
oCell.Select
Selection.Rows.Delete
End If
End If
End If
Next oCell
Next oTbl
lbl_Exit:
Exit Sub
End Sub

[Kilroy]

Greg, it works perfect. I thought you meant I should replace the original lines with a loop statement. Something I don't have any experience with. The more I read the statements you given me the more I learn and I appreciate the schooling. Sometimes it's hard to teach an old dog like me new tricks.

[gmaxey]

The abuse is intended school and not be abusive ;-)

[gmaxey]

Kilroy,

If you have additional questions then rather than send me private messages, post here so others may benefit:


Sub KilRoysLackOfReasonableEffortFixed()
Dim oDoc As Document 'Declares variable oDoc as document object
Dim oTbl As Table 'Declares variable oTbl as a table object
Dim oCell As Cell 'Declares variable oCell as a cell object
ActiveDocument.Range.Copy 'Copies the entire active document
Set oDoc = Documents.Add 'Creates a new blank document based on Normal template
oDoc.Range.Paste 'Pastes the content of the original document into the new document
For Each oTbl In oDoc.Tables 'Loops through each table in the documents table collection
For Each oCell In oTbl.Range.Cells 'Loops through each cell in a particular table
If oCell.Range.Information(wdEndOfRangeColumnNumber) = 4 Then 'If the cell has a column index = 4 then act on it
If oCell.Range.Information(wdEndOfRangeRowNumber) > 2 Then 'If the cell has a row index > 2 (rows 1 and 2 are your heading rows) then continue to act on it
If Left(oCell.Range, Len(oCell.Range) - 2) <> "N" And _ 'All this mash is stripping the end of cell marker to evaluate the cell text content.
Left(oCell.Range, Len(oCell.Range) - 2) <> vbNullString Then 'If it is NOT "N" and NOT empty then continue to act on the cell
oCell.Select 'Since your table has merged vertical cells, you can't use the row indexes so we must select the cell
Selection.Rows.Delete 'Then delete the rows contained in the selection.
End If 'Closes an If ... End If statement
End If 'Closes an If... End If statement
End If 'Closes an If... End If statement
Next oCell 'Process next cell
Next oTbl 'Process next table
lbl_Exit:
Exit Sub
End Sub


Trying stepping through the code using the F8 key.