#1
|
|||
|
|||
Making a Paragraph Report - Check Paragraphs For First & Last Characters
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 is this possible? dan88 |
#2
|
||||
|
||||
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?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#5
|
|||
|
|||
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 dan |
#6
|
|||
|
|||
I think i have a mini idea,
it may be picking up empty paragraphs? |
#7
|
||||
|
||||
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#8
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
|||
|
|||
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 |