Martti

Depois de muitos testes, uma apanhado de códigos que resolveram minha necessidade.
Necessário adequação para problemas específicos.
Sub FormataCélulas() Application.ScreenUpdating = False Dim cw As Double, rh As Double, cwA As Double, c As Range Dim lng As Long, lastrow As Long With Range("A32:AD32") .MergeCells = False cwA = .Cells(1).ColumnWidth For Each c In .Cells cw = cw + c.ColumnWidth Next c cw = cw + .Count * 0.66 .Cells(1).ColumnWidth = cw .Cells(1).wrapText = True .EntireRow.AutoFit rh = .RowHeight .Cells(1).ColumnWidth = cwA .MergeCells = True .RowHeight = rh .HorizontalAlignment = xlJustify .VerticalAlignment = xlJustify End With '------------------------------------------------------------------------------------------------------------------------------- For lng = lastrow To 1 Step -1 If Rows(lng).RowHeight > 408 Then Rows(lng + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove Rows(lng).Resize(1).Select Selection.RowHeight = 409 Cells(lng, "A").Resize(1, 32).Select With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .wrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ReadingOrder = xlContext .MergeCells = True .ShrinkToFit = True End With End If If lastrow > 1 Then ActiveCell.Offset(-1, 0).Range("A32:AD32").Select End If lastrow = lastrow - 1 Next Application.ScreenUpdating = True End Sub