How to tell if text fits in a cell? - vba

Question

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?

Answer 1

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.

Answer 2

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!