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_pages/vba_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_pages/vba_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