CODEWITHSUNDEEP
vbaexcel
Johan
Johan

Reputation: 76640

How to tell if text fits in a cell?

I would like to write some vba code that monitors the OnChange event for a sheet and does some adjustment if text does not fit a cell. I.e. make the text smaller or wrap etc..

I know a can have Excel to automatically shrink the text and I know how to enable wrap in vba, but...

how do I check in vba whether the text fits in a cell to begin with?

Upvotes: 2

Views: 5465

Answers (2)

LS_ᴅᴇᴠ
LS_ᴅᴇᴠ

Reputation: 11181

I'm using THE "dirty" method - that's only one I know: force AutoFit and check new width/height.

However, we can't grantee that was chosen cell that forced new fit. So I opt by copying cell content to an empty worksheet.

That, of course, cause a lot of other problems, and more workarounds.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Fits(Target) Then
        'Notice that Target may have multiple cells!!!
    End If
End Sub

Function Fits(ByVal Range As Range) As Boolean
    Dim cell As Range, tmp_cell As Range, da As Boolean, su As Boolean
    'Stores current state and disables ScreenUpdating and DisplayAlerts
    su = Application.ScreenUpdating: Application.ScreenUpdating = False
    da = Application.DisplayAlerts: Application.DisplayAlerts = False
    'Creates a new worksheet and uses first cell as temporary cell
    Set tmp_cell = Range.Worksheet.Parent.Worksheets.Add.Cells(1, 1)
    'Assume fits by default
    Fits = True
    'Enumerate all cells in Range
    For Each cell In Range.Cells
        'Copy cell to temporary cell
        cell.Copy tmp_cell
        'Copy cell value to temporary cell, if formula was used
        If cell.HasFormula Then tmp_cell.Value = cell.Value
        'Checking depends on WrapText
        If cell.WrapText Then
            'Ensure temporary cell column is equal to original
            tmp_cell.ColumnWidth = cell.ColumnWidth
            tmp_cell.EntireRow.AutoFit 'Force fitting
            If tmp_cell.RowHeight > cell.RowHeight Then 'Cell doesn't fit!
                Fits = False
                Exit For 'Exit For loop (at least one cell doesn't fit)
            End If
        Else
            tmp_cell.EntireColumn.AutoFit 'Force fitting
            If tmp_cell.ColumnWidth > cell.ColumnWidth Then 'Cell doesn't fit!
                Fits = False
                Exit For 'Exit For loop (at least one cell doesn't fit)
            End If
        End If
    Next
    tmp_cell.Worksheet.Delete 'Delete temporary Worksheet
    'Restore ScreenUpdating and DisplayAlerts state
    Application.DisplayAlerts = da
    Application.ScreenUpdating = su
End Function

Has solution got too complex, there may be some problems I didn't preview.

This won't work in read-only workbooks, however, cells in read-only workbooks don't change as well!

Upvotes: 2

Siddharth Rout
Siddharth Rout

Reputation: 149315

Quick and dirty way which will not require you to check each and every cell.

I use this method to usually show all the data.

Sub Sample()
    With Thisworbook.Sheets("Sheet1").Cells
        .ColumnWidth = 254.86 '<~~ Max Width
        .RowHeight = 409.5 '<~~ Max Height
        .EntireRow.AutoFit
        .EntireColumn.AutoFit
    End With
End Sub

I use this method if I want to wrap the text (If Applicable) and keep the row width constant

Sub Sample()
    With Thisworbook.Sheets("Sheet1").Cells
        .ColumnWidth = 41.71 '<~~ Keep the column width constant
        .RowHeight = 409.5
        .EntireRow.AutoFit
    End With
End Sub

Note: This is not applicable for merged cells. For that there is a separate method.

Upvotes: 3

Related Questions