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