Autofit Row Heights In Merged Cells

  • Hi,


    I have this code to fit row heights in merged cells. This works ok but it takes a few minutes to run. I also have the problem of when I insert a new row or delete a row these cell references are then no longer correct. Can anyone adjust this formula to speed it up and use maybe a named range to reference these cells so they adjust when rows are inserted and deleted before the code is run?


    [VBA]Sub Fit_Row_Heights()
    Dim mw As Single
    Dim cM As Range
    Dim Rng As Range
    Dim cw As Double
    Dim rwht As Double
    Dim ar As Variant
    Dim i As Integer
    Application.ScreenUpdating = False
    ar = Array("C14", "C61", "C108", "C155", "C202", "C249", "C296", "C343", "C390", "C437", "C534", "C484", "C531", "C578", "C625", "C672", "C719", "C766", "C813", "C860", "C907", "C954", "C1001", "C1048", _
    "C1095", "C1142", "C1189", "C1236", "C1283", "C1330", "C1377", "C1424", "C1471", "C1518", "C1565", "C1612", "C1659", "C1706", "C1753", "C1800", "C1847", "C1894", "C1941", "C1988", "C2035", "C2082", "C2129", _
    "C2176", "C2223", "C2270", "C2317", "C2364", "C2411", "C2458", "C2505", "C2552", "C2599", "C2646", "C2693", "C2740", "C2787", "C2834", "C2881", "C2928", "C2975", "C3022", "C3069", "C3116", "C3163", "C3210", _
    "C3257", "C3304", "C3351", "C3398", "C3445", "C3492", "C3539", "C3586", "C3633", "C3680", "C3727", "C3774", "C3821", "C3868", "C3915", "C3962", "C4009", "C4056", "C4103", "C4150", "C4197", "C4244", "C4291", _
    "C4338", "C4385", "C4432", "C4479", "C4526", "C4573", "C4620", "C4667", "C4714", "C4761", "C4808", "C4855", "C4902", "C4949", "C4996", "C5043", "C5090", "C5137", "C5184", "C5231", "C5278", "C5325", "C5372", _
    "C5419", "C5466", "C5513", "C5560", "C5607", "C5654", "C5701", "C5748", "C5795", "C5842", "C5889", "C5936", "C5983", "C6030", "C6077", "C6124", "C6171", "C6218", "C6265", "C6312", "C6359", "C6406", "C6453", _
    "C6500", "C6547", "C6594", "C6641", "C6688", "C6735", "C6782", "C6829", "C6876", "C6923", "C6970", "C7017", "C7064", "C7111", "C7158", "C7205", "C7252", "C7299", "C7346", "C7393", "C7440", "C7487", "C7534", _
    "C7581", "C7628", "C7675", "C7722", "C7769", "C7816", "C7863", "C7910", "C7957", "C8004", "C8051", "C8098", "C8145", "C8192", "C8239", "C8286", "C8333", "C8380", "C8427", "C8474", "C8521", "C8568", "C8615", _
    "C8662", "C8709", "C8756", "C8803", "C8850", "C8897", "C8944", "C8991", "C9038", "C9085", "C9132", "C9179", "C9226", "C9273", "C9320")
    For i = 1 To UBound(ar)
    On Error Resume Next
    Set Rng = Range(Range(ar(i)).MergeArea.Address)
    With Rng
    .MergeCells = False
    cw = .Cells(1).ColumnWidth
    mw = 0
    For Each cM In Rng
    cM.WrapText = True
    mw = cM.ColumnWidth + mw
    Next
    mw = mw + Rng.Cells.Count * 0.66
    .Cells(1).ColumnWidth = mw
    .EntireRow.AutoFit
    rwht = .RowHeight
    .Cells(1).ColumnWidth = cw
    .MergeCells = True
    .RowHeight = rwht
    End With
    Next i
    Application.ScreenUpdating = True
    End Sub[/VBA]


    Thanks in advance for any help with this!

  • For quickly try this if your merge area struktur as same as example in col c,d and e
    example you have merge in c1:e1
    Step 1 : you must know columnwidth in col c,d,e by clik in format columnwidth
    For example total column width = 25
    Step 2 = in z1 = +c1
    Step 3 wrap text in z1 and clik autofit row
    You can record then

  • t

    graha_karya,


    Thanks for your reply. Is there a way to use a named range instead of listing every cell?


    try this

  • Finaly if you want dinamic range merge cell to autofit

  • I tried running this code I had to cancel it as it was running for near 10 minutes and still never finished. I dont need to do the whole of column C just them individual cells.


    Thanks

  • Code
    1. Sub xxz()
    2. For Each r In [B]Range("C:C").SpecialCells(2) 'change with first column Autofit[/B]
    3. If r.MergeCells = True Then
    4. If U Is Nothing Then Set U = r.Cells(1) Else Set U = Union(U, r.Cells(1))
    5. End If
    6. Next r
    7. If not u is nothing then U.name ="Deskription" end sub
  • perhab for dinamic range wrap text like this