Find and Replace rows in a table based on bold text.

OfficeAssociate99 · #1 07-21-2017, 07:34 AM

Hi, I am completely new to VBA, so I apologize for any errors/formatting issues.
Basically, I want this program to do this:
1. Search and find a bold keyword (1st category heading)

2. Find the next bold word after (the next category heading)
3. Copy all rows in between the two categories
4. Paste rows in another document (under the 1st category heading)

Here is the code I have so far:

Code:

Const myKeyTerms            As String = _
    "Aerospace, Space & Defence"
Dim myTable                 As Table
Dim myRow                   As Row
Dim myRange                 As Range
Dim myRange2                 As Range
Dim myTable2                 As Table
Dim myRow2                   As Row
Documents.Open ("")
    For Each myTable In ActiveDocument.Tables
        For Each myRow In myTable.Rows
            ' If successful myrange is moved to the found text
            Set myRange = myRow.Range
            ' Search parameters are persistent so you only need to change them if the search parameters change
            With myRange.Find
                .Font.Bold = True
                .Text = ""
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .Wrap = wdFindStop
                .Forward = True
                ' Stop when the range is searched
                ' .Execute returns true if the search is found
                Do While .Execute
                    ' myRange is now the found term
                    myRange.Select
                    If InStr(myKeyTerms, myRange.Text) > 0 Then
                        'Actions to do if the row contained a key term in bold
                       myRange.Copy
                       ThisDocument.Activate
                       For Each myTable2 In ActiveDocument.Tables
                        For Each myRow2 In myTable2.Rows
                            ' If successful myrange is moved to the found text
                        Set myRange2 = myRow2.Range
                            ' Search parameters are persistent so you only need to change 'them if the search parameters change
                             With myRange2.Find
                            .Font.Bold = True
                            .Text = ""
                            .Format = True
                            .MatchCase = False
                            .MatchWholeWord = False
                            .MatchWildcards = False
                            .Wrap = wdFindStop
                            .Forward = True
                            ' Stop when the range is searched
                            ' .Execute returns true if the search is found
                             Do While .Execute
                                ' myRange is now the found term
                                myRange2.Select
                                If InStr(myKeyTerms, myRange2.Text) > 0 Then
                                    Selection.PasteAndFormat (wdTableInsertAsRows)
                                    Exit Sub
                                End If
                          '  reset myRange to encompass the rest of the row
                                myRange2.Start = myRange2.End + 1
                                myRange2.End = myRow2.Range.End
                                
                                myRange2.Select
                                Loop
                                End With
                                Next myRow2
                                Next myTable2
                    End If
                    ' now we need to reset myRange to encompass the rest of the row
                    myRange.Start = myRange.End + 1
                    myRange.End = myRow.Range.End
                                       myRange.Select
                Loop
            End With
        Next myRow
    Next myTable
End Sub

gmayor · #2 07-22-2017, 12:53 AM

Without the tables, it is impossible to test against what you have, but the following should be close

Code:

Option Explicit

Sub Macro1()
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jul 2017
Const myKeyTerms As String = _
      "Aerospace, Space & Defence"
Dim oDoc As Document
Dim oTarget As Document
Dim oTable As Table
Dim oRng As Range
Dim oNew As Range
Dim oCell As Cell

    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    oTarget.Range.Text = myKeyTerms & vbCr
    oTarget.Paragraphs(1).Range.Font.Bold = True
    If oDoc.Tables.Count = 0 Then
        MsgBox "No tables in this document?"
        GoTo lbl_Exit
    End If
    For Each oTable In oDoc.Tables
        Set oRng = oTable.Range
        With oRng.Find
            Do While .Execute(FindText:=myKeyTerms)
                If oRng.InRange(oTable.Range) Then
                    If oRng.Font.Bold = True Then
                        oRng.Start = oRng.Rows(1).Range.Next.Rows(1).Range.Start
                        oRng.End = oTable.Range.End
                        For Each oCell In oRng.Cells
                            If oCell.Range.Font.Bold = True Then
                                oRng.End = oCell.Range.Start
                                Exit For
                            End If
                        Next oCell
                        Exit Do
                    End If
                End If
                oRng.Collapse 0
            Loop
        End With
        Set oNew = oTarget.Range
        oNew.Collapse 0
        oNew.FormattedText = oRng.FormattedText
    Next oTable
lbl_Exit:
    Set oDoc = Nothing
    Set oTarget = Nothing
    Set oRng = Nothing
    Set oNew = Nothing
    Set oTable = Nothing
    Set oCell = Nothing
    Exit Sub
End Sub

OfficeAssociate99 · #3 07-24-2017, 07:57 AM

Sorry, I was out of the office for the weekend, but I am back now. Your code almost works, but I think I didn't explain myself clearly enough the first time.

Master Document: The place I want to input all the new data.

Source Document: Where all the new data is drawn from.

Here is what my tables look like:

Source Document:
Row1: "Aerospace, Space & Defence"
Row2: New Data
Row3: New Data
Row4: "Agri Foods"

I want to copy all the data in between the two headings. Then:

Master Document:
Row1: "Aerospace, Space & Defence"
Row2: Old Data
Row3: "Agri Foods"

I want to paste the new data and replace the old data. Note that the number of rows under each heading varies.

Any help would be greatly appreciated! Thanks so much.

gmayor · #4 07-26-2017, 12:01 AM

As I said before, without the documents, this type of process is impossible to test. There is there is simply too much potential for error to waste the time programming something that may not work, and then start over to try something else. I give a lot of my spare time to helping users with their programming problems, as do a number of fellow contributors, but we don't relish that time being wasted.

My last message included code that worked on the premise that the extracted code was to be written to a new document. Now it appears that you want to write the data to another document that already has data which is different from the first document.

For example, does that second document have the same number of tables. Is the data in the first document going in the same numbered table in the second document.

There is too much scope for ambiguity.

OfficeAssociate99 · #5 07-26-2017, 07:20 AM

Maybe I didn't make myself clear enough. Each week I am given varying amounts of information under predetermined headings. Right now, I have to copy and paste each row individually. What I am trying to do is take all the rows under each heading in the source document, and paste them under the headings in the master document. I do appreciate the effort that individuals such as yourself put into helping less capable coders such as me.

I have already written code (with help from others on this forum) to do error handling in case that there is a new heading that is not among the predetermined ones. It might help explain what I am trying to do.

Code:

Const myKeyTerms            As String = _
    "OrganizationDate+Description+Aerospace, Space & Defence+Automotive+Manufacturing+Life Sciences+Information Communication Technologies / Digital+Natural Resources / Energy+Regional Stakeholders+Other Policy Priorities+NIL+Nil+nil"
Dim i                       As Integer
Dim myTable                 As Table
Dim myFirstRange            As Range
Dim mySecondRange           As Range
Dim myRemoveRange           As Range
Dim SecondRangeFlag         As Boolean
i = ThisDocument.Tables.Count
Documents.Open ("")
    For Each myTable In ActiveDocument.Tables
        Set myFirstRange = Nothing
        SecondRangeFlag = False
        Do
            If myFirstRange Is Nothing Then
                Set myFirstRange = fnFindBold(mySearchRange:=myTable.Range.Rows(1).Range)
            Else
                Set myFirstRange = fnFindBold(mySearchRange:=myFirstRange.Next(Unit:=wdRow))
            End If
            ' two possible cases for myFirstrange
            ' 1. a found range
            ' 2. nothing - which means we have searched the whole table.
            If Not myFirstRange Is Nothing Then
                If InStr(myKeyTerms, myFirstRange.Text) = 0 Then
                    ' Found bold text that is not a defined category (key term)
                    Set mySecondRange = myFirstRange.Duplicate
                    Do
                        Set mySecondRange = fnFindBold(mySecondRange.Next(Unit:=wdRow))
                        If mySecondRange Is Nothing Then
                            SecondRangeFlag = True
                        Else
                            If InStr(myKeyTerms, mySecondRange.Text) > 0 Then
                                SecondRangeFlag = True
                            End If
                        End If
                    Loop Until SecondRangeFlag
                    'We have now found text that is a defined category key term
                    Set myRemoveRange = myFirstRange.Duplicate
                    If mySecondRange Is Nothing Then
                        myRemoveRange.End = myTable.Range.End
                        Set myFirstRange = Nothing
                    Else
                        myRemoveRange.End = mySecondRange.Previous(Unit:=wdRow).End
                        Set myFirstRange = mySecondRange
                    End If
                    myRemoveRange.Select
                    myRemoveRange.Copy
                    ThisDocument.Tables(i).Select
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.PasteAndFormat (wdTableInsertAsRows)
                    i = i + 1
                    Documents("").Activate
                    ActiveDocument.Tables(1).Select
                    Selection.Collapse Direction:=wdCollapseEnd
                    Selection.PasteAndFormat (wdTableInsertAsRows)
                    myRemoveRange.Select
                    myRemoveRange.Cut
                End If
            End If
        Loop Until myFirstRange Is Nothing
    Next myTable
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to find and replace headings in bold and underline	redzan	Word VBA	4	02-13-2016 12:24 PM
Find, select, and replace part of text with bold	paik1002	Word VBA	4	12-07-2015 11:24 PM
VBA Table – Search All Tables - Find & Replace Text in Table Cell With Specific Background Color	jc491	Word VBA	8	09-30-2015 06:10 AM
find and replace in bold	redzan	Word VBA	1	07-27-2014 03:35 PM
Word VBA Macro to Find and Replace based on the Alt Text of an Image	bennymc	Word VBA	1	01-27-2014 04:23 PM