2

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?

4

2 回答 2

3

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.

于 2013-09-11T06:32:05.253 回答
2

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

但是，我们不能授予被选中的单元格以强制新拟合。所以我选择将单元格内容复制到一个空的工作表中。

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

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

解决方案太复杂，可能有一些我没有预览的问题。

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

于 2013-09-11T09:21:30.857 回答