In that case the following will work, but not if there is a space between the asterisk and the paragraph break
Code:
Option Explicit
Sub ParagraphReport()
Dim oSource As Document
Dim oTbl As Table
Dim oTarget As Document
Dim oPara As Paragraph
Dim oRng As Range
Dim strFolder As String
Dim strFile As String
Application.ScreenUpdating = False
Set oTarget = Documents.Add
oTarget.PageSetup.Orientation = wdOrientLandscape
Set oTbl = oTarget.Tables.Add(oTarget.Range, 1, 2)
With oTbl.Rows(1)
.Cells(1).Range.Text = " Text Paragraph"
.Cells(2).Range.Text = "File Name"
End With
strFolder = GetFolder
strFile = Dir(strFolder & "\*.do*", vbNormal)
While strFile <> ""
Set oSource = Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
For Each oPara In oSource.Paragraphs
Set oRng = oPara.Range
oRng.End = oRng.End - 1
If Not oRng.Characters.First = "*" Or Not oRng.Characters.Last = "*" Then
With oTbl
.Rows.Add
.Rows.Last.Range.Cells(1).Range.Text = oPara.Range.Text
.Rows.Last.Range.Cells(2).Range.Text = oSource.Name
End With
End If
Next oPara
oSource.Close wdDoNotSaveChanges
DoEvents
strFile = Dir()
Wend
lbl_Exit:
Set oSource = Nothing
Set oPara = Nothing
Set oRng = Nothing
Set oTarget = Nothing
Set oTbl = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub