vba - テキストがセルに収まるかどうかを確認する方法は?

Question

シートの OnChange イベントを監視し、テキストがセルに収まらない場合に調整を行う vba コードを書きたいと思います。つまり、テキストを小さくしたり、折り返したりします。

テキストを自動的に縮小するExcelを使用できることは知っていますが、vbaでラップを有効にする方法は知っていますが...

そもそもテキストがセルに収まるかどうかをvbaでチェックするにはどうすればよいですか?

Answer 1

私は「汚い」方法を使用しています-それは私が知っている唯一の方法です: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

ソリューションが複雑になりすぎた場合、プレビューしていない問題がいくつかある可能性があります。

これは読み取り専用ブックでは機能しませんが、読み取り専用ブックのセルも変更されません!