format paragraph where font size is greater than set value

[dagerr]

Hi,
Is it possible to format paragraph where font size is greater than set value. e.g. set value = 15 and code changing paragraph where font size = 20 or 25 or 50... but not change paragraphs where font size = 14 or 9...



Sub xml_test()
'
' xml_test
'
'
Selection.Find.ClearFormatting
With Selection.Find.Font
.Size = 15
.bold = False
.Italic = False
End With
With Selection.Find.ParagraphFormat
.Alignment = wdAlignParagraphJustify
End With

Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = "<Title>^&</Title>"
.Forward = True
.Wrap = wdFindContinue
.Format = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

[gmaxey]

Sub Test()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
While .Execute
If oRng.Font.Size > 14 Then
'Do something here.
End If
Wend
End With
End Sub

[dagerr]

It is never ending loop:


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
End If
Wend
End With
End Sub

[gmaxey]

Collapsethe rangeto it’s end after your two sreps

[dagerr]

Ok it works but it is formatting only one first paragraph where font size is greater than 14, I want to format all paragraphs in document.


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
End If
Exit Do
Loop
End With
End Sub

[gmayor]

Remove the line
Exit Do which limits the search to the first instance.

[dagerr]

Remove the line
Exit Do which limits the search to the first instance.

no, back to infinite loop

[gmaxey]

This code ran here on a simple sample document runs and works without a continuous loop. Send a sample your having trouble with:


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
End If
Loop
End With
End Sub

[dagerr]

23114
It happens when in document are two empty paragraphs with font size bigger than 14, I know that it is wrong formatting of document and should be no empty paragraphs, but I receive it like this one, and maybe it is better to put a part of code wich will ignore empty paragraphs or remove empty paragraphs like this one below, I don't know what is better:


Sub delete_empty_paragraph()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

[gmaxey]

The code I provided earlier does not continuously loop here even with two empty paragraphs with font larger than 14 points. But, this might be more what you are looking to do:


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.End = oRng.End - 1
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End + 1
End If
Loop
End With
End Sub

[macropod]

Do note that Greg's code won't process paragraphs with mixed font sizes, which could occur with run-in headings.

[dagerr]

Do note that Greg's code won't process paragraphs with mixed font sizes, which could occur with run-in headings.
Paul, that situation will not gonna happen with my documents - every time the same font size. Example document still have infinite loop, I really don't know why.


Greg's code working without infinite loop but added my tags to empty paragraphs but probably i found a solution, please check it:


Sub remove_empty_paragraph_xml()

Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 And Len(oRng.Paragraphs(1).Range.Text) > 1 Then
oRng.End = oRng.End - 1
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End + 1
End If
Loop
End With

End Sub

[gmaxey]

What example document? You have not posted an example document!

[dagerr]

What example document? You have not posted an example document!

http://www.vbaexpress.com/forum/attachment.php?attachmentid=23114&d=1541073252

[gmaxey]

Sorry, about that.


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
.Wrap = wdFindStop
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.End = oRng.End - 1
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End + 1
End If
Loop
End With
End Sub

[dagerr]

Sorry, about that.


Sub Title_xml()
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
.Wrap = wdFindStop
Do While .Execute
If oRng.Font.Size > 14 Then
oRng.End = oRng.End - 1
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End + 1
End If
Loop
End With
End Sub

ok, no problem but still inserting on empty paragraphs. Look on mine code, I added one line and it is seems to be ok


Sub remove_empty_paragraph_xml()

Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "*^13"
.Format = True
.MatchWildcards = True
Do While .Execute
If oRng.Font.Size > 14 And Len(oRng.Paragraphs(1).Range.Text) > 1 Then 'added line
oRng.End = oRng.End - 1
oRng.InsertAfter "</Title>"
oRng.InsertBefore "<Title>"
oRng.Collapse wdCollapseEnd
oRng.End = oRng.End + 1
End If
Loop
End With

End Sub

[gmaxey]

Well you need to add the .Wrap = wdFindStop to prevent the looping.

[macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.Text = "(*)^13"
.Replacement.Text = "<Title>\1</Title>^p"
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 29 To 144
.Font.Size = i / 2
.Execute Replace:=wdReplaceAll
Next
End With
End With
Application.ScreenUpdating = True
End Sub
The above code processes everything from 14.5pt to 72pt and, in a long document, may be much faster than looping through every paragraph. If you're confident that the point sizes lie within a narrower range, adjust the 29 and/or 144 accordingly for faster execution.

[gmaxey]

Paul,

That is still affecting the empty paragraphs. Maybe:


Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.Text = "(*)^13"
.Replacement.Text = "<Title>\1</Title>^p"
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 29 To 144
.Font.Size = i / 2
.Execute Replace:=wdReplaceAll
Next
End With
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = True
.Text = "<Title></Title>"
.Replacement.Text = ""
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End With
End With
Application.ScreenUpdating = True
End Sub

... this results in the addition of an empty paragraph at the end of the sample document. Don't know if that is problem or not.

[macropod]

That is still affecting the empty paragraphs.
Granted, but one really shouldn't have such paragraphs in a properly-formatted document. As an alternative to your approach, one could change:
.Text = "(*)^13"
in the code I posted to:
.Text = "([!^13]@)^13"
This also avoids the empty last paragraph your code creates.