Question

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

我知道可以让Excel自动缩小文本，我知道如何在vba中启用wrap，但是......

如何检查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并检查新的宽度/高度。

然而，我们不能被选为强制新的选择的细胞。所以我选择将单元格内容复制到空工作表中。

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

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

解决方案是否过于复杂，可能会出现一些我未预览的问题。

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

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

2 个答案: