copying specific rows

[Kilroy]

Nonconformance Procedure QA.docx

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]

Nonconformance Procedure QA.docx

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.