Need help with a script with Selection and If for Font Size < 8?

Cendrinne · #1 06-04-2023, 07:00 PM

I feel I'm so close but searching doesn't come up with solution

I have

Code:

Sub TESTS_If_Font_size_below_8p5_put_Font_size_8p5()
Dim Rng As Range

With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Execute
  End With
   Do While .Find.found = True
      If .Font.Size < 8.5 Then

           .Find.Replacement.Font.Size = 8.5
           
      End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
End Sub

Why it does nothing? No error message but no action

Need advice please

Unless it's not doable? I keep searching.

C

BrianHoard · #2 06-04-2023, 07:47 PM

Hello, please see if this script works for you.
For testing, I also am highlighting the characters < 8.5 in yellow so you can see which ones were changed. Just comment that line out when you're ready.

A couple things that may also help that I've added:
- An undo record so this script can be undone in a single undo action.
- I'm storing the desiredFontSize at the top of the script as a variable, in case you need to change it in the future, it's easy to find.

Code:

Sub fontFixer()
  Dim docRange As Range
  Set docRange = ActiveDocument.Content
  
  Dim scriptName As String
  scriptName = "fontFixer"
  
  Dim desiredFontSize As Double
  desiredFontSize = 8.5
  
  Dim bhhUndo As UndoRecord
  
  Dim currentFontSize As Double
    
  Application.ScreenUpdating = False
    
  ' Begin undo record
  Set bhhUndo = Application.UndoRecord
  bhhUndo.StartCustomRecord (scriptName)
  
  ' Loop through each character
  For Each Char In docRange.Characters
    ' Get current font size
    currentFontSize = Char.Font.Size
    
    ' If currentFontSize < desiredFontSize, set it to desiredFontSize
    If currentFontSize < desiredFontSize Then
      Char.HighlightColorIndex = wdYellow ' Highlight the character in yellow
      Char.Font.Size = desiredFontSize
    End If
  Next Char
  
  bhhUndo.EndCustomRecord ' End undo
  Application.ScreenUpdating = True

End Sub

Cendrinne · #3 06-04-2023, 07:57 PM

As is I got error message for ''Char'', since it said Not defined.

So I Dim it:

Code:

Dim Char As Characters

Then I got another message for Font on this line:

Code:

currentFontSize = Char.Font.Size

Well, I've copied it that row and past it under, while puting the first row not active.
If you back it up to remove ''.Font.Size'', then put a dot, it's true, it won't give you the previous choices.
ie:

Code:

   'currentFontSize = Char.Font.Size
    currentFontSize = Char.

But it was a good effort. Let's see if we can try to find something together

Thanks so much for trying

******By the way, I have Option Explicit, on top of the module, if that could explain the reason I get error message.

C

Cendrinne · #4 06-04-2023, 08:25 PM

Cause I have a freaking long script, that works, but I keep trying to shorten it

Code:

Sub FNR_IF_Font_is_below_8p5_put_Font_to_8p5()
'
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 1
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 1.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
         .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
         .Size = 2
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
         .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 2.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 3
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 3.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 4
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 4.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 5.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 6
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 6.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 7
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 7.5
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Size = 8
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find.Replacement.Font
        .Size = 8.5

    End With
    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

It's long, but at least, worst case scenario, I could use this.

But I'm sure there must be a better solution.

C

Cendrinne · #5 06-04-2023, 08:48 PM

Found someting here

Code:

Sub CommentMania()
'found here in forum :https://www.msofficeforums.com/word-vba/38890-macro-font-names-sizes.html
'done by Guessed / Andrew Lockton 2018-06-13 at 9:00 am

  Dim aRng As Range, aPara As Paragraph
  Set aRng = ActiveDocument.Range

  For Each aPara In aRng.Paragraphs
      If aPara.Range.Font.Size < 7 Then
'          aPara.Range.Font.Name <> "Arial"
          aPara.Range.Font.Size = 8.5
      End If

  Next aPara
End Sub

it doesn't highlight, but maybe we can figure it out, but at least it's shorther

Note: with the single quote, I've just deactivated the original script. I often leave them in in case I need to tweek it for testing.
but later on, I remove them. ***I've just removed most of them to not confuse anyone

C

Cendrinne · #6 06-04-2023, 09:07 PM

Here is with variants (Find & Replace) and color Teal the font change, here is the scripts :

Code:

Sub FNR_Font_Mod_ONLY_size_Variant_from_xx_to_xx_with_Colr()
'Works 2023-06-05
'CommentMania, original script name
'found here in forum :https://www.msofficeforums.com/word-vba/38890-macro-font-names-sizes.html
'done by Guessed / Andrew Lockton 2018-06-13 at 9:00 am  // modified by me 2023-06-05

  Dim aRng As Range, aPara As Paragraph
  Dim sVar1 As Variant                'Font Size IF below
  Dim sVar2 As Variant                'Font Size TO change if found
  
  Set aRng = ActiveDocument.Range

    sVar1 = InputBox("Enter the size of the Font to Search for IF below a certain size." _
     & vbCr & "This includes half points. Example : 7.5", "SUGGESTION", "7.5")                                      'For ENG, it's a period vs comma for FRE 7.5 ENG / 7,5 FRE

    sVar2 = InputBox("Enter the desired Font Size, replacing the prior variable, if below...." _
     & vbCr & "This includes half points. Example : 9 ou 8.5", "SUGGESTION", "8.5")                                 'For ENG, it's a period vs comma for FRE 7.5 ENG / 7,5 FRE

  For Each aPara In aRng.Paragraphs
  
     'If aPara.Range.Font.Size < 7 Then
      If aPara.Range.Font.Size <= sVar1 Then
          
'          aPara.Range.Font.Name <> "Arial"
          aPara.Range.Font.Size = sVar2
          aPara.Range.Font.ColorIndex = wdTeal
      End If

  Next aPara

End Sub

Works, again, I didn't search yet for the HighLight, but I'll try it now.

Let me know if it works on your side too

C

Cendrinne · #7 06-04-2023, 09:20 PM

If we want to Highlight and color Teal the font change, here is the scripts:

Code:

Sub FNR_Font_Mod_ONLY_size_Variant_from_xx_to_xx_with_HighLight_Colr()
'Works 2023-06-05
'CommentMania, original script name
'found here in forum :https://www.msofficeforums.com/word-vba/38890-macro-font-names-sizes.html
'done by Guessed / Andrew Lockton 2018-06-13 at 9:00 am  // modified by me 2023-06-05

  Dim aRng As Range, aPara As Paragraph
  Dim sVar1 As Variant                'Font Size IF below
  Dim sVar2 As Variant                'Font Size TO change if found
  
  Set aRng = ActiveDocument.Range

    sVar1 = InputBox("Enter the size of the Font to Search for IF below a certain size." _
     & vbCr & "This includes half points. Example : 7.5", "SUGGESTION", "7.5")                                      'For ENG, it's a period vs comma for FRE 7.5 ENG / 7,5 FRE

    sVar2 = InputBox("Enter the desired Font Size, replacing the prior variable, if below...." _
     & vbCr & "This includes half points. Example : 9 ou 8.5", "SUGGESTION", "8.5")                                 'For ENG, it's a period vs comma for FRE 7.5 ENG / 7,5 FRE

  For Each aPara In aRng.Paragraphs
  
     'If aPara.Range.Font.Size < 7 Then
      If aPara.Range.Font.Size <= sVar1 Then
          
          Options.DefaultHighlightColorIndex = wdYellow
'          aPara.Range.Font.Name <> "Arial"
          aPara.Range.Font.Size = sVar2
          aPara.Range.HighlightColorIndex = wdYellow
          aPara.Range.Font.ColorIndex = wdTeal
      End If

  Next aPara

End Sub

So this is it.

It is found and perfected, well much better than it was.

I thank you for your input and suggesting the idea of highlighting the change

C

Cendrinne · #8 06-04-2023, 10:15 PM

Fixed the scripts

Test this out.
Copy the below, and put the font size as the number prior to text.
Then copy the script and ask to change any font size of ''8 and below'', then run the script, It should color and highlight, everything except for the size 8.5 (since you will ask to find size 8 and below).

7
Sub FNR_SI_Format_Police_sous_Grosseur_7_met_grosseur_ 8p5_avec_variable()
'Works 2023-06-05
'CommentMania, original script name
'found here in forum :https://www.msofficeforums.com/word-...mes-sizes.html
'done by Guessed / Andrew Lockton 2018-06-13 at 9:00 am // modified by me 2023-06-05

7.5
Dim aRng As Range, aPara As Paragraph
Dim sVar1 As Variant 'Font Size IF below
Dim sVar2 As Variant 'Font Size TO change if found
Set aRng = ActiveDocument.Range

6.5
sVar1 = InputBox("Entre la grosseur de la police recherché si en bas de la grosseur désirée." _
& vbCr & "Pour des demi-points, met une virgule. Exemple : 7,5", "SUGGESTION", "7,5") 'pour les anglais, c'est point vs virgule 7.5 ENG / 7,5 FRE

sVar2 = InputBox("Entre la grosseur de la police à remplacé si trouvé en bas de...." _
& vbCr & "Pour des demi-points, met une virgule. Exemple : 9 ou 8,5", "SUGGESTION", "8,5") 'pour les anglais, c'est point vs virgule 8.5 ENG / 8,5 FRE

8.5
For Each aPara In aRng.Paragraphs

If aPara.Range.Font.Size <= sVar1 Then

Options.DefaultHighlightColorIndex = wdYellow

8
aPara.Range.Font.Size = sVar2
aPara.Range.HighlightColorIndex = wdYellow
aPara.Range.Font.ColorIndex = wdTeal
End If

Next aPara

End Sub

Let me know how it turns out for others

C

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA - Word how to globally change the font and font size in footnotes	thomasoj	Word VBA	3	01-15-2020 06:26 AM
Merging two Word documents: 2nd document not maintaining original font type and font size	Swarup	Word	31	08-28-2018 06:55 PM
Word 10: need information typed to be in font of default selection instead of Template Font	1SickPuppy	Word	1	05-06-2017 03:00 PM
Font size showing different (some superscripted??) but tools show its the same size?	mikkygee	PowerPoint	4	12-14-2015 11:21 PM
Looping Macro to Change Font, Font Size, and Give Heading 1	WH7262	Word VBA	1	08-26-2014 03:46 PM