3

プログラムで、結合されたセルにテキストを連続して挿入しています。折り返しテキストを設定しており、必要に応じて行の高さを拡張して、複数行のテキストに対応させたいと考えています。セルがいっぱいになったらプログラムで AutoFit を適用していましたが、うまくいきませんでした。その後、結合されたセルに対して AutoFit が機能しないというナレッジ ベースの記事を見つけました。折り返しテキストの行数に対応するために必要な行の高さを計算することができます。しかし、文字の幅などの計算に乗り込みたくはありません。どんなアイデアでも感謝します。

質問のクレジットはDavidに送られます（私はまったく同じ質問をしましたが、後世のためにここに再投稿しました）ソース

4

1 に答える 1

5

ここで、アクティブ シート上の結合セルの自動調整をシミュレートするVB マクロを見つけました。MrExcel.com からのソース クレジット パリー

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i


'Take a note of current active cell
Set StartCell = ActiveCell

'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
    With c.MergeArea
    If .Rows.Count = 1 And .WrapText = True Then
        If MergeRng Is Nothing Then
            Set MergeRng = c.MergeArea
            ReDim a(0)
            a(0) = c.MergeArea.Address
        Else
        Set isect = Intersect(c, MergeRng)
            If isect Is Nothing Then
                Set MergeRng = Union(MergeRng, c.MergeArea)
                ReDim Preserve a(UBound(a) + 1)
                a(UBound(a)) = c.MergeArea.Address
            End If
        End If
    End If
    End With
End If
Next c


Application.ScreenUpdating = False

'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
      With ActiveCell.MergeArea
            If .Rows.Count = 1 And .WrapText = True Then
                'Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                ActiveCellWidth = ActiveCell.ColumnWidth
                For Each CurrCell In Selection
                    MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
                Next
                .MergeCells = False
                .Cells(1).ColumnWidth = MergedCellRgWidth
                .EntireRow.AutoFit
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = ActiveCellWidth
                .MergeCells = True
                .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                  CurrentRowHeight, PossNewRowHeight)
            End If
        End With
MergedCellRgWidth = 0
Next i

StartCell.Select
Application.ScreenUpdating = True

'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing

End Sub
于 2013-10-25T19:53:28.123 に答える