Making a Paragraph Report - Check Paragraphs For First & Last Characters

dan88 · #1 04-29-2016, 07:17 AM

Greetings all,

Sorry to hear the Server deleted all the threads.

I am posting again.

I am looking to check my documents for specific type of formatting.

Each paragraph first character is a star *

Paragraph Last character is a star *

What I am trying to do is loop through documents. If a paragraph does not start or end with a star

Copy that paragraph to a table.

My vba is not very good but i have come up with the idea, the code does not work understandably.

Code:

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

Please advise and many many thanks for helping.

is this possible?

dan88

macropod · #2 04-29-2016, 04:30 PM

Quote:

Originally Posted by dan88

Each paragraph first character is a star *

Paragraph Last character is a star *

What I am trying to do is loop through documents. If a paragraph does not start or end with a star

Is it possible that some paragraphs begin with an asterisk but don't end with one, or vice-versa? If so, what do you want to do about those?

dan88 · #3 04-30-2016, 06:15 AM

Hi Paul,

thank you for replying.

In my haste I forgot to mention

If the paragraph is missing a * at the beginning or end copy that paragraph to table.

Example

* Washington is a city

Mr Abraham was a president*

===========

These are good below

* Life is great*

* a very long long paragraph........*

So long as the paragraph first character begins with a * and the last character ends with a star - those are good.

Thank you
dan88

gmayor · #4 04-30-2016, 06:47 AM

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

dan88 · #5 04-30-2016, 08:06 AM

Hello Graham,

thank you for helping.

I am afraid something went wrong

I received 220 pages, when i tested it on 2 documents

Here is the code i used - I only added the folder function

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

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

any ideas - it kept repeating the file name over and over

dan

dan88 · #6 04-30-2016, 08:21 AM

I think i have a mini idea,

it may be picking up empty paragraphs?

gmayor · #7 04-30-2016, 08:42 PM

An empty paragraph is still a paragraph, so if it doesn't have asterisks it will be reported. If you want to omit empty paragraphs then replace the loop with

Code:

For Each oPara In oSource.Paragraphs
            If Len(oPara.Range) > 1 Then
                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
            End If
        Next oPara

There is no need to have empty paragraphs in a document. Use the space options of paragraph styles to insert the spacing between paragraphs.

macropod · #8 04-30-2016, 11:07 PM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocSrc As Document, wdDocTgt As Document
Set wdDocTgt = ActiveDocument
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> wdDocTgt.FullName Then
    Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, _
      AddToRecentFiles:=False, Visible:=False)
    With wdDocSrc
      With .Range
        .InsertBefore vbCr
        With .Find
          .ClearFormatting
          .Text = "^13[\*][!^13]@[\*]^13"
          .Replacement.Text = "^p"
          .Forward = True
          .Wrap = wdFindContinue
          .Format = False
          .MatchWildcards = True
          .Execute Replace:=wdReplaceAll
        End With
        wdDocTgt.Characters.Last.FormattedText = .FormattedText
      End With
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
With wdDocTgt.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  .Characters.First.Delete
  While .Characters.Last.Previous = vbCr
    .Characters.Last.Previous = vbNullString
  Wend
End With
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
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

dan88 · #9 05-01-2016, 06:29 AM

Thank you Mr Graham & Mr Paul,

you have been superstars - I have a nice paragraph report it is super!!!

Made a nice sunday for me

thank you - nice weekend to you all

dan

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Automation Process of Schedule Report Output and Report Check Score Card !	ozman86	Word VBA	1	11-19-2014 11:52 PM
making translated paragraphs consecutive	user2969	Word	1	01-29-2014 09:00 PM
Cannot select single characters. Word selects paragraphs or parts of sentences.	TMinnich	Word	2	10-25-2013 09:38 AM
How to combine many paragraphs in one paragraph?	Jamal NUMAN	Word	25	03-08-2013 04:31 AM
Making sure the correct number of characters are entered.	leroytrolley	Excel	1	07-25-2008 06:38 AM