That's a great suggestion. I changed one line of your code to
Code:
If InStr(aRng.Text, "Worksheet") > 0 And InStr(aTbl.Range.Cells(aTbl.Range.Cells.Count).Range.Text, "n/a") = 0 Then
This keeps the macro from pulling any n/a results. I've added a header to the others that were missing it, like the Comparison Results one.
In case you're interested, here is the final code I came up with. I used your code to help me format the paragraphs in the destination cell so it's much easier to read. You probably could have done it alot "prettier", but hey, it works
Code:
Sub Results2()
Dim i As Integer, iTables As Integer
Dim aTbl As Table, tblLast As Table, tblTgt As Table, aCellTgt As Cell
Dim aRng As Range, aRngEnd As Range, aRngSource As Range
iTables = ActiveDocument.Tables.Count
Set tblLast = ActiveDocument.Tables(iTables)
Set tblTgt = tblLast.Tables(2)
Set aCellTgt = tblTgt.Cell(1, 2)
aCellTgt.Range.Text = "" 'if you want to start with a blank cell
For i = 1 To iTables - 1
Set aTbl = ActiveDocument.Tables(i)
Set aRng = aTbl.Range.Cells(1).Range
If InStr(aRng.Text, "Worksheet") > 0 And InStr(aTbl.Range.Cells(aTbl.Range.Cells.Count).Range.Text, "n/a") = 0 Then
Set aRngSource = aTbl.Range.Cells(aTbl.Range.Cells.Count).Range
aRngSource.MoveEnd Unit:=wdCharacter, Count:=-1
Set aRngEnd = aCellTgt.Range
aRngEnd.Collapse Direction:=wdCollapseEnd
aRngEnd.MoveEnd Unit:=wdCharacter, Count:=-1
aRngEnd.FormattedText = aRngSource.FormattedText
aRngEnd.InsertAfter vbCr & vbCr
End If
Next i
tblLast.Tables(2).Cell(1, 2).Select
With Selection.Font
.Bold = False
.Name = "Times New Roman"
.Size = 10
.ColorIndex = wdBlack
With aCellTgt.Range
.ParagraphFormat.SpaceAfter = 0
.ParagraphFormat.SpaceBefore = 0
End With
End With
tblLast.Tables(2).Cell(1, 2).Select
Selection.HomeKey Unit:=wdLine
Selection.TypeParagraph
tblLast.Tables(2).Cell(1, 2).Select
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Text = "Methodology"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.TypeParagraph
Selection.Text = "The following methodologies were used in the examination of this case:"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.TypeParagraph
Selection.Text = "Visual Examination"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.Text = "Physical Examination"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.Text = "Physical Measurements"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.Text = "Microscopic Examination"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.Text = "Microscopic Comparison"
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.TypeParagraph
Selection.Text = "Database Search"
Dim p As Integer, pParagraph As Integer
Dim r As Range
tblLast.Tables(2).Cell(1, 2).Select
pParagraph = Selection.Paragraphs.Count
tblLast.Tables(2).Cell(1, 2).Range.InsertParagraphAfter
For p = 1 To pParagraph
Set aParagraph = tblLast.Tables(2).Cell(1, 2).Range.Paragraphs(p)
Set aRng = aParagraph.Range
If InStr(aRng.Text, "Result") > 0 Then
aRng.Select
With Selection.Font
.Bold = True
End With
End If
If InStr(aRng.Text, "Result") = 0 Then
aRng.Select
Selection.Paragraphs.LeftIndent = 18
End If
If InStr(aRng.Text, "Methodology") > 0 Then
aRng.Select
With Selection.Font
.Bold = True
End With
Selection.Paragraphs.LeftIndent = 0
End If
Next p
Selection.Document.Undo
Selection.Paragraphs.LeftIndent = 18
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeBackspace
End Sub
Thank you so much for your help!