Format text automatically

macropod · #16 04-20-2013, 01:25 AM

Hi dexter30,

The only practical way to do that is with a macro. Try:

Code:

Sub Demo()
With ActiveDocument.Content
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13DO[S ]{1,2}VEREADOR*^13DO[S ]{1,2}VEREADOR"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    .End = .Start + InStrRev(.Text, vbCr) - 2
    .Start = .Start + 1
    .Start = .Start + InStr(.Text, vbCr)
    .Text = Replace(.Text, vbCr, " ")
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub

Notes: The FIND is case-sensitive; if there are any of your other 'Nº [0-9]{1;8}' strings between the 'DO(S) VEREADOR(A/ES)' ranges, they'll be merged with the surrounding 'DO(S) VEREADOR(A/ES)' ranges; and the last 'DO(S) VEREADOR(A/ES)' range in the document won't be processed.

dexter30 · #17 04-22-2013, 08:01 AM

In the attached file (PD_BEFORE) the macro works for the first four 'Nº [0-9]{1;8}' strings. I doesn´t do for the last one (Nº 516/2013), then MS Word freezes and I have to force it shut down.

The result after executing the macro 'Demo' is shown in the PD_AFTER_Sub_Demo file. Note also that it merged Nº 499/2013 and Nº 507/2013 (DA VEREADORA, I think you skipped this possibility)

macropod · #18 04-22-2013, 03:29 PM

I did warn you that the last one wouldn't be processed and that other instances between the 'DO(S) VEREADOR(A/ES)' ranges would be merged into them.

To handled 'DA' as well, change:
.Text = "^13DO[S ]{1,2}VEREADOR*^13DO[S ]{1,2}VEREADOR"
to:
.Text = "^13D[AO][S ]{1,2}VEREADOR*^13D[AO][S ]{1,2}VEREADOR"

For the 'freezing' try changing:
.Wrap = wdFindContinue
to:
.Wrap = wdFindStop

dexter30 · #19 04-23-2013, 09:41 AM

Yes now it works and doesn´t freeze anymore.

I just realized that there can be more than one 'Nº [0-9]{1;8}' for each 'DO/A(S) VEREADOR(A/ES)'. Can you please update the macro to handle it?

Also isn´t really there a way to process the last one?

Example files attached.

Thank you.

macropod · #20 04-24-2013, 04:34 AM

Doing all this stuff makes the macro much more complicated:

Code:

Sub Test()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Text = "^13D[AO][S ]{1,2}VEREADOR*^13"
    .Replacement.Text = ""
    .Execute
  End With
  Do While .Find.Found
      .Start = .Start + 1
      Do While .Paragraphs.Last.Next.Range.Font.Bold = False And .Paragraphs.Last.Next.Range.End <> ActiveDocument.Range.End
        .MoveEnd wdParagraph, 1
      Loop
      For i = .Paragraphs.Count To 2 Step -1
        If Not .Paragraphs(i).Range.Text Like "Nº #*" Then
          If Not .Paragraphs(i).Range.Text Like "D[AO][S ]*VEREADOR*" Then .Paragraphs(i).Range.Characters.First.Previous = " "
        End If
      Next
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  With .Find
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "[^13]"
    .Replacement.Text = "^p^p"
    .Execute Replace:=wdReplaceAll
    .Text = "(^13D[AO][S ]{1,2}VEREADOR*)[^13]{1,}"
    .Replacement.Text = "\1^p"
    .Execute Replace:=wdReplaceAll
  End With
End With
With ActiveDocument.Range
  While .Characters.Last.Previous.Text = vbCr
    .Characters.Last.Previous.Text = vbNullString
  Wend
End With
Application.ScreenUpdating = True
End Sub

dexter30 · #21 04-25-2013, 01:25 PM

Awesome job. This would save me a lot of everyday work.

Don´t understand though why the script inserts several blank lines in
the beginning of the file.

Also, in the last 'Nº [0-9]{1;8}' the paragraph turned to 'Multiple' (menu Format/Paragraph/Between Lines) where it should be 'Single'.

Thank you.

macropod · #22 04-25-2013, 03:07 PM

Quote:

Originally Posted by dexter30

Don´t understand though why the script inserts several blank lines in the beginning of the file.

None of your previous posts indicated there was anything in the file before the content of interest, so I didn't code for that. What you have there really should have the spacing controlled by paragraph formatting, not by the insertion of empty paragraphs. The same applies to the spacing between the paragraphs in area you want the macro to modify.

Quote:

Also, in the last 'Nº [0-9]{1;8}' the paragraph turned to 'Multiple' (menu Format/Paragraph/Between Lines) where it should be 'Single'.

That has nothing to do with the macro changing any paragraph formatting. Rather, it's because your document's last paragraph already has that formatting and your content's last paragraph ends up being the document's last paragraph...

dexter30 · #23 04-25-2013, 05:14 PM

Quote:

Originally Posted by macropod

That has nothing to do with the macro changing any paragraph formatting. Rather, it's because your document's last paragraph already has that formatting and your content's last paragraph ends up being the document's last paragraph...

Yes, you´re right. I just checked the original document and it has its last line set to 'Multiple'

Quote:

Originally Posted by macropod

None of your previous posts indicated there was anything in the file before the content of interest, so I didn't code for that. What you have there really should have the spacing controlled by paragraph formatting, not by the insertion of empty paragraphs. The same applies to the spacing between the paragraphs in area you want the macro to modify.

Blame it on me, I didn´t think the previous lines would be so relevant. Is there any solutions for those empty lines in the beginning of the file? Maybe apply the script to a selection?

Thank you.

macropod · #24 04-25-2013, 07:25 PM

Try the following update:

Code:

Sub Test()
Application.ScreenUpdating = False
Dim i As Long, RngFnd As Range, RngTmp As Range
With ActiveDocument
  Set RngFnd = .Range
  Set RngTmp = .Range
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "^13D[ao][s ]{1,2}Vereador*^13"
      .Replacement.Text = ""
      .Execute
    End With
    RngFnd.Start = .Start
    RngTmp.Start = .Start
  End With
  With RngTmp
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "[^13]{2,}"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      .Text = "^13D[ao][s ]{1,2}Vereador*^13"
      .Replacement.Text = ""
      .Execute
    End With
    Do While .Find.Found
      .Start = .Start + 1
      Do While .Paragraphs.Last.Next.Range.Font.Bold = False And .Paragraphs.Last.Next.Range.End <> ActiveDocument.Range.End
        .MoveEnd wdParagraph, 1
      Loop
      For i = .Paragraphs.Count To 2 Step -1
        If Not .Paragraphs(i).Range.Text Like "Nº #*" Then
          If Not .Paragraphs(i).Range.Text Like "D[ao][s ]*Vereador*" Then .Paragraphs(i).Range.Characters.First.Previous = " "
        End If
      Next
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
  Set RngTmp = RngFnd
  With RngTmp.Find
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = "[^13]"
    .Replacement.Text = "^p^p"
    .Execute Replace:=wdReplaceAll
    .Text = "(^13D[ao][s ]{1,2}Vereador*)[^13]{1,}"
    .Replacement.Text = "\1^p"
    .Execute Replace:=wdReplaceAll
  End With
  With .Range
    While .Characters.Last.Previous.Text = vbCr
      .Characters.Last.Previous.Text = vbNullString
    Wend
  End With
End With
Application.ScreenUpdating = True
End Sub

dexter30 · #25 04-26-2013, 11:41 AM

It worked like a charm. I really appreciate your help.

Believe it or not, my boss told me to include a new part in the document named PROPOSITURAS RESPONDIDAS, and this one is being affected by the script.

Right after 'PROPOSITURAS RESPONDIDAS' every block of text to be merged begins with either of the following:
'Do Vereador XXX:' / 'Dos Vereadores XXX, YYY e ZZZ:' /
'Da Vereadora XXX:' / 'Das Vereadoras XXX, YYY e ZZZ:' /
'Do Vereador XXX e Da Vereadora XXX:' /
'Dos Vereadores XXX, YYY e ZZZ e Das Vereadora XXX, YYY e ZZZ:'

Then there may be either of the following:
Indicação nº / Indicações nºs
Requerimento nº / Requerimentos nºs
Moção nº / Moções nºs
Ofício de Gabinete nº / Ofícios de Gabinete nºs

Note that a semicolon must be inserted to separate each series of Indicações / Requerimentos / Moções / Ofícios de Gabinete

Example files attached.

Thanks again.

macropod · #26 04-26-2013, 06:56 PM

This is the fifth change to your requirements you've made in this thread. I really don't enjoy having to re-do stuff just because the requirements haven't been properly specified from the start.

Since you say your boss wants to include a new part to the document, how about adding that after the macro has been run? Your additional requirements are expanding the project way beyond what its reasonable to seek free help for ...

dexter30 · #27 04-26-2013, 07:20 PM

Quote:

Originally Posted by macropod

I really don't enjoy having to re-do stuff just because the requirements haven't been properly specified from the start.

Yes, I know it must be a pain, but I just couldn´t know beforehand my boss would ask me for that extra work.

Quote:

Originally Posted by macropod

Since you say your boss wants to include a new part to the document, how about adding that after the macro has been run? Your additional requirements are expanding the project way beyond what its reasonable to seek free help for ...

That would solve the problem of the messed up lines, but not the new merge work. And I would have to do all that extra work every day, after the macro has been run.

Anyway thanks a lot for your help and time, you guys do an awesome job here.

dexter30 · #28 04-29-2013, 12:47 PM

Would you consider solve this one, it's really the LAST thing I need to get the document ready.

macropod · #29 05-05-2013, 05:23 PM

Try the following:

Code:

Sub Reformat()
Application.ScreenUpdating = False
Dim i As Long, RngFnd As Range
With ActiveDocument
  Set RngFnd = .Range
  With .Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "[^13]{1,}D[ao][s ]{1,2}Vereador*^13"
      .Replacement.Text = ""
      .Execute
    End With
    RngFnd.Start = .Start + 1
  End With
  With RngFnd
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .MatchWildcards = True
      .Text = "[^13]{1,}"
      .Replacement.Text = "^p^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[ ]{1,}^13"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(D[ao][s ]{1,2}Vereador*)([^13]{1,})"
      .Replacement.Text = "^p\1^l"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(Nº)"
      .Replacement.Text = "^p^l\1"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(MATÉRIA DO LEGISLATIVO)[^13]{1,}"
      .Replacement.Text = "^p^l\1^l^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(INDICAÇÕES)[^13]{1,}"
      .Replacement.Text = "^p^l\1^l^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(MOÇÕES)[^13]{1,}"
      .Replacement.Text = "^p^l\1^l^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{2,}"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
      .Text = "^l"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
      .Text = "[^13]{1,}(D[ao][s ]{1,2}Vereador*)([^13]{1,})"
      .Replacement.Text = "^p^p\1^p"
      .Execute Replace:=wdReplaceAll
    End With
  End With
End With
Application.ScreenUpdating = True
End Sub

dexter30 · #30 05-07-2013, 10:59 AM

Fantastic. Close to perfection.

Remember I said that a semicolon should be inserted to separate each series of Indicações / Requerimentos / Moções / Ofícios de Gabinete? Like this:

BEFORE

Da Vereadora Arminda Gonda:
Indicações n°s 5864 de 2012, 854, 856, 973, 982, 984, 1017, 1022, 1343, 1345, 1346, 1347 e 1349 de 2013
Requerimento n° 77 de 2013
Moção nº 30 de 2013

AFTER

Da Vereadora Arminda Gonda:
Indicações n°s 5864 de 2012, 854, 856, 973, 982, 984, 1017, 1022, 1343, 1345, 1346, 1347 e 1349 de 2013; Requerimento n° 77 de 2013; Moção nº 30 de 2013

Thank you.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to find text in between two characters and then format selected text?	qcom	Word	5	02-19-2015 11:23 PM
automatically format meetings by me with some attendee	wsw70	Outlook	0	06-24-2011 12:16 AM
Objective: Automatically export email text,attachment text to DB friendly format	SilentLee	Outlook	0	11-14-2010 02:45 PM
automatically extract footnotes into new file and apply character format to footnote	hrdwa	Word	0	02-27-2010 03:16 AM
format cells to automatically place quotes around text	dirtleg	Excel	1	09-16-2008 01:52 PM