AutoFitMergedCellRowHeight în Excel

Problemă: având mai multe celule Excel unite (merge cell), dacă lungimea şirului de caractere introduse depăşeşte lungimea celulei, înălţimea rândului nu se măreşte astfel încât să fie afişat întreg conţinutul celulei, chiar dacă opţiunea Wrap cell este activată.

La această adresă, se găseşte o soluţie care încearcă să rezolve această problemă: funcţia AutoFitMergedCellRowHeight().

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.MergeCells Then
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
End If
End Sub

Problema ce persista era aceea că după apăsarea tastei Enter şi selectarea celulei de sub cea curentă (conform setărilor implicite ale Excel), nu avea loc o redimensionare a înălţimii rândului pentru a se afişa toate caracterele din celula editată, fiind necesară o reselectare manuală a celulei respective, moment în care avea loc redimensionarea înălţimii rândului.

Am găsit soluţia după multe căutări . Şi culmea e destul de simplu. La apelarea funcţiei, am forţat reselectarea celulei atribuind proprietăţii MoveAfterReturnDirection valoarea xlUp.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Run "AutoFitMergedCellRowHeight"
Application.MoveAfterReturn = True
Application.MoveAfterReturnDirection = xlUp
Application.MoveAfterReturn = False
End Sub

Postări asemănătoare pe categorii