Extracting a row if a certain word is present

[mikewi]

Good morning all. I'm new to VBA and still at the using the recorder stage for writing. I'm wondering if there is a way to extract an entire row from a table if there is a certain word in a cell in column 2 and export those rows to a new word document. I've tried the recorder with no luck. Any direction is appreciated.

[gmayor]

You will not manage that with the recorder

The following should work

Option Explicit

Sub CopyRows()
'Graham Mayor - http://www.gmayor.com - 28/10/2016
Dim oSourceTable As Table
Dim oTargetTable As Table
Dim oSource As Document
Dim oTarget As Document
Dim oCell As Range
Dim oRng As Range
Dim oRow As Row
Dim i As Long
Const strWord As String = "Lorem"    ' the word to find
    Set oSource = ActiveDocument
    'make sure you have the right document
    If oSource.Tables.Count = 0 Then
        MsgBox "No tables in the active document?"
        GoTo lbl_Exit
    End If
    'identify the source table
    Set oSourceTable = oSource.Tables(1)
    'Create a new document to take the found rows
    Set oTarget = Documents.Add
    'Add a one row empty table with as many columns as the source table
    'Note this will not work with merged or split cells/rows
    Set oTargetTable = oTarget.Range.Tables.Add(oTarget.Range, 1, oSourceTable.Columns.Count)
    'Check each rfow
    For Each oRow In oSourceTable.Rows
        'See if the target word is in cell 2
        Set oCell = oRow.Cells(2).Range
        If InStr(1, oCell.Text, strWord) > 0 Then
            'if it is make sure we have a new empty row available
            If InStr(1, oTargetTable.Rows.Last.Cells(2).Range.Text, strWord) > 0 Then
                oTargetTable.Rows.Add
            End If
            'get the cell contents and reproduce them in the target table
            For i = 1 To oRow.Cells.Count
                Set oCell = oTargetTable.Rows.Last.Cells(i).Range
                oCell.End = oCell.End - 1
                Set oRng = oRow.Cells(i).Range
                oRng.End = oRng.End - 1
                oCell.FormattedText = oRng.FormattedText
            Next i
        End If
    Next oRow
lbl_Exit:
    'clean up
    Set oSource = Nothing
    Set oTarget = Nothing
    Set oSourceTable = Nothing
    Set oTargetTable = Nothing
    Set oRow = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[mikewi]

Thanks Graham. I appreciate your help but unfortunately there are merged cells in the first column. maybe there is a code out there for unmerging cells to match the column beside it that I can run first?

[mikewi]

I found this code that looks for the letter N in column 4 of a table and copies with merged cells. Can it be modified to look for a given word in a cell of column 2?

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

[gmayor]

You would newed to post an example table so we can see what needs to be done.

[mikewi]

I attached an an example. Ideally I would like to be able to state the search word or words if that's even possible. If not I can just change the search word in the code?

[gmayor]

The merged rows are a pain to deal with, but thankfully you don't have merged columns as well. The macro I posted earlier requires a few minor changes to the code to enable it to be used with variable texts and column numbers. That's the easy part.

The more complicated part is to grab all the rows, fill in the missing data, and then work with the new table. The following may not be the simplest version of the code, but it does work and I have spent enough time on it. If you want to tidy it up further - feel free

Option Explicit

Sub ExtractRowData()
'Graham Mayor - http://www.gmayor.com - 30/10/2016
Dim oCell As Cell
Dim oRng As Range, oNum As Range
Dim oNewRng As Range
Dim oNewCell As Range
Dim oTable As Table
Dim oNewTable As Table
Dim oDoc As Document
Dim oTemp As Document
Dim iCol As Long, iRow As Long

    Set oDoc = ActiveDocument
    Set oTemp = Documents.Add
    Set oTable = oDoc.Tables(1)
    Set oNewTable = oTemp.Tables.Add(oTemp.Range, oTable.Rows.Count, oTable.Columns.Count)
    For Each oCell In oTable.Range.Cells
        iRow = oCell.RowIndex
        iCol = oCell.ColumnIndex
        Set oRng = oCell.Range
        oRng.End = oRng.End - 1
        oNewTable.Cell(iRow, iCol).Range.FormattedText = oRng.FormattedText
    Next oCell
    With oNewTable
        For iRow = 2 To .Rows.Count
            Set oNewRng = .Cell(iRow, 1).Range
            oNewRng.End = oNewRng.End - 1
            If oNewRng.Text = "" Then
                Set oNum = .Cell(iRow - 1, 1).Range
                oNum.End = oNum.End - 1
                oNewRng = oNum
            End If
        Next iRow
    End With
    CopyRows oTemp
lbl_Exit:
    Set oDoc = Nothing
    Set oTemp = Nothing
    Set oTable = Nothing
    Set oNewTable = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Set oNewRng = Nothing
    Set oNum = Nothing
    Exit Sub
End Sub

Sub CopyRows(oSource As Document)
'Graham Mayor - http://www.gmayor.com - 28/10/2016
'Updated 30/10/2016
Dim oSourceTable As Table
Dim oTargetTable As Table
Dim oTarget As Document
Dim oCell As Range
Dim oRng As Range
Dim oRow As Row
Dim i As Long, j As Long
Dim strWord As String, strCol As String


    'identify the source table
    Set oSourceTable = oSource.Tables(1)
    strWord = InputBox("Enter word or phrase to find")
    If strWord = "" Then GoTo lbl_Exit
Again:
    strCol = InputBox("Find in which column?")
    If Not IsNumeric(strCol) Or _
       val(strCol) > oSourceTable.Columns.Count _
       Or val(strCol) = 0 Then
        MsgBox "Enter a numeric value no greater than the number of columns in the table!"
        GoTo Again:
    End If
    j = CLng(strCol)

    'Create a new document to take the found rows
    Set oTarget = Documents.Add
    'Add a one row empty table with as many columns as the source table
    'Note this will not work with merged or split cells/rows
    Set oTargetTable = oTarget.Range.Tables.Add(oTarget.Range, 1, oSourceTable.Columns.Count)
    'Check each rfow
    For Each oRow In oSourceTable.Rows
        'See if the target word is in cell 2
        Set oCell = oRow.Cells(j).Range
        If InStr(1, oCell.Text, strWord) > 0 Then
            'if it is make sure we have a new empty row available
            If InStr(1, oTargetTable.Rows.Last.Cells(j).Range.Text, strWord) > 0 Then
                oTargetTable.Rows.Add
            End If
            'get the cell contents and reproduce them in the target table
            For i = 1 To oRow.Cells.Count
                Set oCell = oTargetTable.Rows.Last.Cells(i).Range
                oCell.End = oCell.End - 1
                Set oRng = oRow.Cells(i).Range
                oRng.End = oRng.End - 1
                oCell.FormattedText = oRng.FormattedText
            Next i
        End If
    Next oRow
    oSource.Close 0
lbl_Exit:
    'clean up
    Set oSource = Nothing
    Set oTarget = Nothing
    Set oSourceTable = Nothing
    Set oTargetTable = Nothing
    Set oRow = Nothing
    Set oCell = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[mikewi]

Graham this works amazingly. I wouldn't change any of it (even I knew how). It is more versatile than I thought it could be. This is such an amazing tool. thank you so much.

[gmaxey]

You don't have to change, but here is a version tailored your example:

Option Explicit
Sub FilterTableContent()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
Dim strText As String
Dim strRef As String
  ActiveDocument.Tables(1).Range.Copy
  Set oDoc = Documents.Add
  oDoc.Range.Paste
  Set oTbl = oDoc.Tables(1)
  strText = InputBox("Enter the search text")
  For Each oCell In oTbl.Range.Cells
    If oCell.RowIndex > 1 And oCell.ColumnIndex = 2 Then
      On Error Resume Next
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) <> vbNullString Then
        strRef = Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2)
      End If
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) = vbNullString Then
        oTbl.Cell(oCell.RowIndex, 1).Range.Text = strRef
      End If
      On Error GoTo 0
      If Not InStr(UCase(oCell.Range.Text), UCase(strText)) > 0 Then
        oCell.Range.Select
        Selection.Rows.Delete
      End If
    End If
  Next
lbl_Exit:
  Set oDoc = Nothing: Set oTbl = Nothing: Set oCell = Nothing
  Exit Sub
End Sub

Posted just to illustrate that there are usually several ways to solve the same problem. Where Graham is extracting the valid text, I have done the opposite and eliminated the invalid text.

[mikewi]

Greg Thanks a lot, this one works great as well and it keeps the source formatting which I like. Not wanting to push my luck or anything but Would I be able to use the part of Grahams code to have the second window pop up asking for the column? I know this wasn't part of the original question but it really opens up the possibilities for me and other uses, extremely useful tool for my work. Also Could someone recommend a place to go online for lessons with visual basic? I'm fascinated with learning how to do this and I don't want to beg for help for ever.

[gmaxey]

Again, the code I posted was customized for your example, but something like this should work:

Option Explicit
Sub FilterTableContent()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
Dim strText As String
Dim strRef As String
Dim lngCol As Long
  ActiveDocument.Tables(1).Range.Copy
  Set oDoc = Documents.Add
  oDoc.Range.Paste
  Set oTbl = oDoc.Tables(1)
  strText = InputBox("Enter the search text")
  lngCol = CLng(InputBox("Enter column to search", "2"))
  For Each oCell In oTbl.Range.Cells
    If oCell.RowIndex > 1 And oCell.ColumnIndex = lngCol Then
      On Error Resume Next
      'Assumes that reference cell is column 1
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) <> vbNullString Then
        strRef = Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2)
      End If
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) = vbNullString Then
        oTbl.Cell(oCell.RowIndex, 1).Range.Text = strRef
      End If
      On Error GoTo 0
      If Not InStr(UCase(oCell.Range.Text), UCase(strText)) > 0 Then
        oCell.Range.Select
        Selection.Rows.Delete
      End If
    End If
  Next
lbl_Exit:
Set oDoc = Nothing: Set oTbl = Nothing: Set oCell = Nothing
Exit Sub
End Sub

This is not technically visual basic. It is visual basic for applications. As for learning how, an airline pilot once replied when asked how he learned to fly a 757. "I got in the cockpit and started operating the controls."

I have learned what little I know with similar tinkering. Find a problem and try to figure out how to solve it. Here is a little I've posted on the basics:

http://gregmaxey.mvps.org/word_tip_p...ba_basics.html

[gmayor]

Greg and I have a similar approach to programming, and often collaborate on projects, so I would agree with him that the best approach to learning to program is to decide what it is that you want to do and then work out how to do it, to which end there are thousands of examples available on line, including quite a few useful functions on my web site. There are also several people willing to help when you get stuck, in forums like this one. Structured learning won't make you proficient, but it is handy to learn a few basic techniques. Greg has a primer on his web site http://gregmaxey.mvps.org/word_tip_p...ba_basics.html which is a good place to start.

There is also usually more than one way to achieve the ends you require, as the two examples here show. The only real requirements are that it works and works reliably - especially if other users are going to employ your code, because I can guarantee that, if a user can screw it up, he or she will. It doesn't really matter how ugly your code is, if it works, though it can make it much harder for others to edit your code later, if it is a mess. You will get better as your knowledge increases.

As for retaining the formatting, you can do that also with my code, by creating the new documents using the original document as a template (the code posted uses the normal template). You would have to pass the original document path to the second macro (in the same way I have passed the document), but that would be easy enough to add.

[mikewi]

Thanks to both of you for helping me out. I will read through both of your sites and hopefully be able to become more proficient. I do have one more question. When I enter the text to search it brings back more than I enter. As an example - If I put in "Inspect" I get Inspector, Inspection, inspected. Is there a way for it to be refine it to bring back exactly and only what entered to the pop up search box?

[gmaxey]

There is but I am not at a PC. I'll post a modification later this afternoon.

[gmaxey]

Ok, there are several ways to determine if a sub-string "the requirements" is contained in a larger string of text "These are the requirements for this test." One, which Graham and I both used is the InStr function. It is quick and simple. However, it has a drawbacks as you discovered. Another is to use the find method and "matchwholeword":

Sub FilterTableContent()
'A basic Word macro coded by Greg Maxey
Dim oDoc As Document
Dim oTbl As Table
Dim oCell As Cell
Dim strText As String, strRef As String
Dim lngCol As Long
Dim oRng As Range

  ActiveDocument.Tables(1).Range.Copy
  Set oDoc = Documents.Add
  oDoc.Range.Paste
  Set oTbl = oDoc.Tables(1)
  strText = InputBox("Enter the search text")
  lngCol = CLng(InputBox("Enter column to search", "2"))
  For Each oCell In oTbl.Range.Cells
    If oCell.RowIndex > 1 And oCell.ColumnIndex = lngCol Then
      On Error Resume Next
       'Assumes that reference cell is column 1
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) <> vbNullString Then
        strRef = Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2)
      End If
      If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) = vbNullString Then
        oTbl.Cell(oCell.RowIndex, 1).Range.Text = strRef
      End If
      On Error GoTo 0
      If Not InStr(UCase(oCell.Range.Text), UCase(strText)) > 0 Then
        'If the base string isn't found then kill the row.
        oCell.Range.Select
        Selection.Rows.Delete
      Else
        'The base string is found so look for the specific string.
        Set oRng = oCell.Range
        oRng.End = oRng.End - 1
        With oRng.Find
          .Text = strText
          .MatchWholeWord = True
          If Not .Execute Then
            oCell.Range.Select
            Selection.Rows.Delete
          End If
        End With
      End If
    End If
  Next
lbl_Exit:
  Set oDoc = Nothing: Set oTbl = Nothing: Set oCell = Nothing
  Exit Sub
End Sub

Note: I intentionally kept a conditional check in this code which "might" make it more efficient in very large documents but for most practical purposes could be removed. See if you can figure out what that check is and why it isn't really necessary.

[mikewi]

I am only guessing but I think it is

If Left(oTbl.Cell(oCell.RowIndex, 1).Range.Text, Len(oTbl.Cell(oCell.RowIndex, 1).Range.Text) - 2) = vbNullString Then 
                oTbl.Cell(oCell.RowIndex, 1).Range.Text = strRef

This guess is through comparing the different versions. I can't qualify my guess.

[gmaxey]

No, you still need that. It is the If InStr part. You now only need the part after the Else. I left it
because checking if the base substring is present may be a tad quicker than actual searching for the exact string.

[mikewi]

I will get it sooner or later. Thanks Greg

[mikewi]

Guys take a look at this sample please. I choose "n" as the text search and column #4. It only takes 4/5 rows that contains an exact match and for some reason does not keep the row with the last occurrence of the search (n). Any thoughts?

[gmaxey]

VBA Find and Replace can be a fickle (odd) thing. That is odd because it works with the other four rows and even odder was I added "N" to the last cell and it kept all six. Odder still I removed the "N" from the last cell and ran it again and that time it kept all the original 5.

While I can' really explain this case, I can demonstrate that Find typically can't find text when that text "IS" or "DEFINES" the scope of the search range. For example, with your sample document step through:

Sub TextToFindIsTheFindRange()
Dim oRng As Range
  Set oRng = ActiveDocument.Tables(1).Range.Cells(2).Range.Words(1)  '"Clause "
  oRng.End = oRng.End - 1 'This defines the search range as the range taken up by the characters in "Clause"
  With oRng.Find
    .Text = oRng.Text 'Clause
    If .Execute Then Beep  'No Beep because Clause isn't found in Clause because Clause is Clause.
  End With
  With oRng.Find
    .Text = "Claus"
    If .Execute Then Beep 'Found because "Claus" is found in "Clause"
  End With
End Sub

With that theory and the code as written it seems that "N" would never have been found but obviously VBA Find is even fickler in tables ;-)

In this part of the original code, take or stet out the oRng.End = Rng.End - 1 line and it should work.

'The base string is found so look for the specific string.
Set oRng = oCell.Range
oRng.End = oRng.End - 1