Sub ParagraphReport()


Dim aSource As Document
    Dim aTbl As Table
    Dim aTarget As Document
    Dim oPara As Paragraph
    
    Dim strFolder As String
    Dim strFile As String
    
    Application.ScreenUpdating = False
    
    Set aTarget = Documents.Add
    
    aTarget.PageSetup.Orientation = wdOrientLandscape
    
    Set aTbl = oTarget.Tables.Add(oTarget.Range, 1, 2)

    With aTbl.Rows(1)
        .Cells(1).Range.Text = " Text Paragraph"
        .Cells(2).Range.Text = "File Name"


    strFolder = GetFolder
    strFile = Dir(strFolder & "\*.do*", vbNormal)
    
    While strFile <> ""
    Set aSource = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
        
    '*****  Below is problem area
    
    For Each oPara In ActiveDocument.Paragraphs
    If NOT InStr(1, oPara.Range.Text.First, "*") > 0 AND  If InStr(1, oPara.Range.Text.Last, "*") > 0  Then
            
     oPara.add

    '*****
    
    End If
    Next oPara
        
        
        
        With aTbl
            .Rows.Add
            .Rows.Last.Range.Cells(1).Range.Text = aSource.oPara.Range.Text
            .Rows.Last.Range.Cells(2).Range.Text = aSoource.strFile.Range.Text
            
        End With
        
        
        oSource.Close wdDoNotSaveChanges
        strFile = Dir()
    Wend
   
    Set aSource = Nothing
    Application.ScreenUpdating = True
lbl_Exit:
    Exit Sub
End Sub



End Sub


Function GetFolder() As String

    'Found on a forum
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
    
    
End Function