Set selected text as string and search for string in a range, VBA Word-CodePudding

I have two tables in a word document, I want search Column2 of Table1 (located in one range) for the text "yes" and, if the text is found, I want to select the text in the cell to the left ("John" in example below). Once that text is selected I want to set that as a string so that I can search for the string in Table2 (located in a second range). Once the string is found in table two i want to navigate to the last column in the row and copy the the text inside. After that I want to paste the text in the table1 cell that contains the original "yes" text that was searched for. I want this to be looped to replace further "yes" text on rows after so that Table1 becomes New Table1 below:

Table1:

Name. Column2

John. Yes

Jill. -

Jane. Yes

Table2:

Name. Column2. Column 3 Column4

John. ---- -- - - - - - -- - - copytext1

Jill

Jane. ---- -- - - - - - -- - - copytext2

New Table1:

Name. Column2

John. copytext1

Jill.

Jane. copytext2

I've written some VBA to try to do this but am having no luck. It currently pastes the last copied text previous to running the macro instead of the text copied from column4. I have tried running the code in parts but it only works when I replace the string with actual text (part 4). Fairly new to VBA so aware that I mightve missed something major but any help would be much appreciated. Thanks in advance.

VBA code:


Sub ReplaceYesWithCopyText()

Set oRng = ActiveDocument.Range
oRng.Start = oRng.Bookmarks("Bookmark1").Range.End
oRng.End = oRng.Bookmarks("Bookmark2").Range.Start


Dim str1 As String
Dim tbl As Table, r As Long
Set tbl = oRng.Tables(1)

For r = 1 To tbl.Rows.Count
 tbl.Cell(r, 3).Range.Select

    Set Rng = Selection.Range
            With Rng.Find
            .ClearFormatting
            .Font.Bold = True
            
'1. Search for yes in row 1 of column three
            .Execute FindText:="Yes", Format:=True, Forward:=True
                    If .Found = True Then
                    
'2. Set cell to left as string
                    tbl.Cell(r, 2).Range.Select
                    str1 = Selection.Paragraphs(1).Range.Text
                    
'3. Set second range to search table 2
                            Set oRng = ActiveDocument.Range
                            oRng.Start = oRng.Bookmarks("Bookmark3").Range.End
                            oRng.End = oRng.Bookmarks("Bookmark4").Range.Start
                            oRng.Tables(1).Select
                            Dim Fnd As Boolean
        
'4. Find name/string in tabke two
                            Set Rng = Selection.Range
                            With Rng.Find
                                .ClearFormatting
                                .Execute FindText:=str1, Forward:=True, _
                                Format:=False, Wrap:=wdFindStop
                                Fnd = .Found
                            End With
        
'5. Navigating to colum 4 and copying cell text
                            If Fnd = True Then
                                With Rng
                                    Selection.EndKey Unit:=wdLine
                                    Selection.EndKey Unit:=wdLine
                                    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                                    'str2 = Selection.Paragraphs(1).Range.Text
                                    Selection.Copy
                                End With
                            End If
                            
'6. Set range back to table 1
                            Set oRng = ActiveDocument.Range
                            oRng.Start = oRng.Bookmarks("Bookmark1").Range.End
                            oRng.End = oRng.Bookmarks("Bookmark2").Range.Start

'7. Find Yes in orginal column and paste info
                            tbl.Cell(r, 3).Range.Select
                            Selection.Paste
                    End If
            End With
    Set Rng = Nothing
Next r

End Sub

CodePudding user response：

For example:

Sub Demo()
Application.ScreenUpdating = False
Dim Tbl1 As Table, Tbl2 As Table, Rng1 As Range, Rng2 As Range, r As Long
With ActiveDocument
  Set Tbl1 = .Tables(1): Set Tbl2 = .Tables(2): Set Rng1 = .Tables(1).Range
  With Tbl1.Range
    With .Find
      .ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchCase = True
      .MatchWholeWord = True
      .MatchWildcards = False
      .Text = "Yes"
      .Replacement.Text = ""
    End With
    Do While .Find.Execute = True
      If .InRange(Rng1) = False Then Exit Sub
      If .Cells(1).ColumnIndex = 2 Then
        r = .Cells(1).RowIndex
        Set Rng2 = Rng1.Tables(1).Cell(r, 1).Range: Rng2.End = Rng2.End - 1
        With Tbl2.Range
          With .Find
            .Text = Rng2.Text
            .Wrap = wdFindStop
            .Execute
          End With
          If .Find.Found = True Then
            Set Rng2 = Tbl2.Cell(.Cells(1).RowIndex, .Rows(1).Cells.Count).Range
            Rng2.End = Rng2.End - 1
            Rng1.Tables(1).Cell(r, 1).Range.FormattedText = Rng2.FormattedText
          End If
        End With
      End If
      .Collapse (wdCollapseEnd)
    Loop
  End With
End With
Application.ScreenUpdating = True
End Sub