VBA to change text size depending on string length

[cjcass]

Hi,
I have a range of cells H20:J50 in Sheet2 that all contain formulas reading text from cells in Sheet1.
For every cell in the range I would like the font size to change relative to the length of the text string shown in the cells H20:J50. So, for text strings with <100 characters font size 10, <150 font size 9 and greater than 150 font size 8. I have seen vba examples in forums but not working with text strings that are the result of formulas.
The cells containing the original text in Sheet1 will change regularly using macros so I don't really want this solution (in Sheet2) to be volatile/slowing down activity in Sheet1 if that makes sense.
Can anyone help?
Many thanks.

 

[cjcass]

ok, I have just found this code which seems to work and I can adapt the font sizes etc, however it slows down the macros running in Sheet1 that change the original cells which are feeding the formulas in Sheet2 which is where this code is placed - how could I isolate this code so it runs on my command?

Private Sub Worksheet_Calculate()


Dim xCell As Range
For Each xCell In Range("H20:J50")
With xCell
If Len(.Text) > 100 Or Val(.Value) > 10 Then
.Font.Name = "Calibri"
.Font.Size = 8
Else
.Font.Name = "Calibri"
.Font.Size = 11
End If
End With
Next


End Sub

 

[steve the fish]

Like this?

Sub ChangeFontSize()

For Each c In Range("H20:J50")
    Select Case Len(c)
        Case 100 To 149
            c.Font.Size = 9
        Case Is > 149
            c.Font.Size = 8
        Case Else
            c.Font.Size = 10
    End Select
Next

End Sub

 

[cjcass]

I seemed to have found my own solution!
Have just set the code up in a standalone macro which I can run at the push of a button.

 

[JackDanIce]

This code should be slightly faster than yours. Also, you may find disabling calculation before the macro runs and re-enabling it after, improves the run time, but it's not clear what the code or formulas on Sheet1 are if this helps or not. Anyway, try:

Private Sub Worksheet_Calculate()

    Dim x   As Long
    Dim y   As Long
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
    With Cells(20, 8).Resize(31, 3).Font
        .Name = "Calibri"
        .Size = 11
        Set rng = .Cells(1, 1)
    End With
    
    For x = 20 To 50
        For y = 8 To 10
            With Cells(x, y)
                If Len(.Text) > 100 Or Val(.Value) > 10 Then Set rng = Union(rng, Cells(x, y))
            End With
        Next y
    Next x
    
    With rng
        .Font.Size = 8
        .Cells(1, 1).Font.Size = 11
    End With
    
    Set rng = Nothing
    
    Application.ScreenUpdating = True
                
End Sub

You can adapt this to run on your command by assigning the code to a button you place on Sheet2; you'd need to change the name of the procedure from Worksheet_Calculate as well.

 

[cjcass]

great, will try these solutions too, thanks.

 

[JackDanIce]

Sorry, small error in mine, try:

Sub Macro1()


    Dim x   As Long
    Dim y   As Long
    Dim rng As Range
    
    Application.ScreenUpdating = False
    
    With Cells(20, 8).Resize(31, 3).Font
        .Name = "Calibri"
        .Size = 11
        Set rng = Parent.Cells(1, 1)
    End With
    
    For x = 20 To 50
        For y = 8 To 10
            With Cells(x, y)
                If (Len(.Text) > 100 + Val(.Value) > 10) < 0 Then Set rng = Union(rng, Cells(x, y))
            End With
        Next y
    Next x
    
    With rng
        .Font.Size = 8
        .Cells(1, 1).Font.Size = 11
    End With
    
    Set rng = Nothing
    
    Application.ScreenUpdating = True


End Sub