如何判断文本是否适合单元格？

我想编写一些vba代码来监控工作表的OnChange事件，并在文本不适合单元格时做一些调整。 即使文本更小或包装等。

我知道一个可以让Excel自动缩小文本，我知道如何启用换行包装，但…

如何检查vba文本是否适合单元格？

Answer 1

快速和肮脏的方式，这将不需要你检查每个细胞。

我使用这种方法通常显示所有的数据。

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 

如果我想包装文本（如果适用）并保持行宽不变，我使用这个方法

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

注意 ：这不适用于合并的单元格。 为此，有一个单独的方法。

Answer 2

我正在使用“脏”的方法 – 这是我所知道的：强制AutoFit并检查新的宽度/高度。

但是，我们不能接受那个被迫select的细胞。 所以我select复制单元格内容到一个空的工作表。

当然，这会导致很多其他问题，以及更多的解决方法。

 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 

解决scheme太复杂了，可能有一些问题我没有预览。

这在只读工作簿中不起作用，但只读工作簿中的单元格也不会改变！