Fitting Text in Cell with Changing Font Size (VBA macro to change font size according to Length of Text)

[Legacy 103420]

As can be seen below I need to change font size depending on length of text.

I'm complete newbie about VBA macros. I ask for learning also. How to write codes to set

if the length of cell is 0-49 set font size 26
if the length of cell is 50-99 set font size 22
if the length of cell is 100-149 set font size 16
if the length of cell is 150-199 set font size 11
if the length of cell is 200-299 set font size 10
if the length of cell is 300-400 set font size 9

2nd question: I set the values manually. Is there a more intelligent macro idea for fitting text in cell using change fonts size by keeping cell dimensions same?

text	length
Lorem ipsum dolor sit amet	26
Lorem ipsum dolor sit amet, consectetur adipisicing elit	56
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.	124
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco	183
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.	233
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur.	335

<tbody>
</tbody>

 

[Greg Hitchon]

How big is your data set?

On a small scale this is the easiest way to do it:

Sub changeFont()
Dim vsz As Variant
Dim rng As Range, rcell As Range


vsz = Array(26, 22, 16, 11, 10, 9)



'not sure what your range is here, can ask if you need to
'set it dynamically (ie rows/columns change)
'*************NEED TO SET THIS TO WHATEVER YOUR RANGE IS**********
Set rng = Range("a1:b100")



'not sure if there is a better way then just looping, could use conditional formatting but thats not too exciting.  if you 
'have large numbers of cells to work with then can work on a more efficient method
For Each rcell In rng
    'includes bound checking, could explicitly set option base instead
    rcell.Font.Size = vsz(LBound(vsz) + WorksheetFunction.Min(Int(Len(rcell.Value) / 50), UBound(vsz) - LBound(vsz)))
Next rcell


End Sub

sets anything over 400 to 9 as well. Let me know if that runs to slow,

 

[rjwebgraphix]

Doing it on the sheet with an onChange event would probably be more effecient if it will need to be done real-time as data changes. If it's a one time thing then Greg's way should get you there.

Using Greg's way, just changed it up for an OnChange Event. You'll still need to enter the range though.

Just right click the sheet's tab, click view code and paste this into the Sheet's code.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim vsz As Variant
Dim rng As Range, rcell As Range


vsz = Array(26, 22, 16, 11, 10, 9)
Set rng = Range("A1:B100")

For Each rcell In rng
    If Not Intersect(Target, rcell) Is Nothing Then
            rcell.Font.Size = vsz(LBound(vsz) + WorksheetFunction.Min(Int(Len(rcell.Value) / 50), UBound(vsz) - LBound(vsz)))
    End If
Next rcell

End Sub

 

[Legacy 103420]

Thanks guys for your helps! The code works fine. I can use Greg's way but rjwebgraphix's instruction is confusing. I couldn't still learn what can I do after paste this into the Sheet's code? I clicked run, a blank macro window is appeared. It's not important for now but I would like to learn

After my post (and before your replies) I've searched similar codes on the net and addes some lines by trial-and-error.

My Vba code was like that

Sub DoReformat()    Dim rCell As Range


    For Each rCell In Selection.Cells
        If Len(rCell.Text) < 46 Then
            rCell.Font.Size = 19
        ElseIf Len(rCell.Text) < 70 Then
            rCell.Font.Size = 17
        ElseIf Len(rCell.Text) < 80 Then
            rCell.Font.Size = 16
        ElseIf Len(rCell.Text) < 96 Then
            rCell.Font.Size = 15
        ElseIf Len(rCell.Text) < 139 Then
            rCell.Font.Size = 13
        ElseIf Len(rCell.Text) < 183 Then
            rCell.Font.Size = 11
        ElseIf Len(rCell.Text) < 240 Then
            rCell.Font.Size = 10.5
        ElseIf Len(rCell.Text) < 285 Then
            rCell.Font.Size = 9
        ElseIf Len(rCell.Text) < 335 Then
            rCell.Font.Size = 8.5
        ElseIf Len(rCell.Text) < 80 Then
            Else
            rCell.Font.Size = 7.5
        End If
    Next
End Sub

Anyway my problem was solved