Move down and selection in table

[Mateusz]

Hello,

I am trying to:
- find key word in Word table
- select cell
- move down 2 cells
- copy all 3 cells (first one with key word + 2 below)

I tired to replace wdLine by wdCell in code below but it did not work.



With Selection.Find .Text = "Contact"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
End With
Selection.Find.Execute
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.HomeKey Unit:=wdLine
Selection.Extend
Selection.Copy

I will be very thankful for sharing with me your ideas to solve this issue.

Best regards
Mateusz

[gmayor]

There are no 'lines' in a table. I assume from your description you mean rows? In which case put your cursor in the table and run the following code.

Sub Macro1()
Dim oTable As Table
Dim oRow As Row
Dim oRng As Range
Dim lRow As Long
Dim bFound As Boolean
Const sFind As String = "Contact" ' Text to find - case sensitive
If Not Selection.Information(wdWithInTable) = True Then
MsgBox "Cursor is not in a table", vbCritical
Exit Sub
End If
On Error GoTo err_Handler
Set oTable = Selection.Tables(1)
For Each oRow In oTable.Rows
If InStr(1, oRow.Range.Text, sFind) > 0 Then
lRow = oRow.Index
Set oRng = oRow.Range
oRng.End = oTable.Rows(lRow + 2).Range.End
oRng.Copy
MsgBox "Rows " & lRow & " to " & lRow + 2 & _
" copied to the clipboard", vbInformation
bFound = True
Exit For
End If
Next oRow
If Not bFound = True Then MsgBox sFind & " was not found", vbInformation
lbl_Exit:
Set oTable = Nothing
Set oRow = Nothing
Set oRng = Nothing
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical
Err.Clear
GoTo lbl_Exit
End Sub

[Mateusz]

Hello,

thank you very much for your help, your skills are awsome.

You are right, in table there are no lines but rows.

I tried the code and it seems that 3 rows in all columns have been copied.
My real intention was to copy 3 cells in one column.
Sorry, maybe I should better explain it:

- find key word in Word table
- select this cell
- move down 2 cells still in the same column
- copy all 3 cells vertically (first one with key word + 2 below)

[gmayor]

It needs an extra step to copy only the cells

Sub Macro1()
Dim oTable As Table
Dim oRow As Row
Dim oCell As Cell
Dim oRng As Range, oStart As Range
Dim lRow As Long, lCol As Long
Dim bFound As Boolean
Const sFind As String = "Contact" ' Text to find - case sensitive
If Not Selection.Information(wdWithInTable) = True Then
MsgBox "Cursor is not in a table", vbCritical
Exit Sub
End If
On Error GoTo err_Handler
Set oStart = Selection.Range
Set oTable = Selection.Tables(1)
For Each oRow In oTable.Rows
If InStr(1, oRow.Range.Text, sFind) > 0 Then
lRow = oRow.Index
For lCol = 1 To oRow.Cells.Count
Set oCell = oRow.Cells(lCol)
If InStr(1, oCell.Range.Text, sFind) > 0 Then
oCell.Select
Selection.MoveDown Unit:=wdLine, Count:=2, Extend:=wdExtend
Set oRng = Selection.Range
Exit For
End If
Next lCol
oRng.Copy
MsgBox "3 cells copied to the clipboard", vbInformation
bFound = True
oStart.Select
Exit For
End If
Next oRow
If Not bFound = True Then MsgBox sFind & " was not found", vbInformation
lbl_Exit:
Set oTable = Nothing
Set oRow = Nothing
Set oCell = Nothing
Set oRng = Nothing
Set oStart = Nothing
Exit Sub
err_Handler:
MsgBox Err.Description, vbCritical
Err.Clear
GoTo lbl_Exit
End Sub