Auto Fit Merged Cell

izet99

New Member
Joined
Nov 5, 2009
Messages
14
Hi, have vba code that I need some help... code below work what is intended to do, basically it looks for merged cell and auto fit/size those cell... my issue is the code run very, very slow... I'm looking to see if there is way to improve it...

Currently, code looking in column C and if finds merged cell with oversized text/content it will resized row high accordingly...

All my merged cells are in sequence starting at row C16 and down, also If helps, I have counter cell in F1 to tell me how many rows contains data.... so if F1 = 51, then I have 51 line of data from C16 down. So instead looking for each cell in column C maybe range from C16 + F1 down would be some sort of counter what to look for… how can I adapt code below…. or is there other alternative to slow performance of this code.

Code:
' Auto fit merged cells

Sub FixMergedSequential()
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
    For i = 10 To Range("C" & Rows.Count).End(xlUp).Row
        On Error Resume Next
        Set rng = Range(Range("C" & i).MergeArea.Address)
        rng.MergeCells = False
        cw = rng.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
        rng.Cells(1).ColumnWidth = mw
        rng.EntireRow.AutoFit
        rwht = rng.RowHeight
        rng.Cells(1).ColumnWidth = cw
        rng.MergeCells = True
        rng.RowHeight = rwht
    Next i
    
 Application.ScreenUpdating = True
 
End Sub

Regards
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
Copy data in merged cell to an unused row below in same column.
Autofit height for that cell
Adjust rows of merged cell based on height of that cell

Code:
Sub SetMergedCellRowHeight(rngAddress As Range)

    Dim lScratchRow As Long
    Dim sngNewRowHeight As Single
    
    'Need row below last used row, but don't wan to creeping
    '  down each time this sub is run.  Using column A
    lScratchRow = Cells(Rows.Count, 1).End(xlUp).Row + 5
    
    rngAddress.Copy Cells(lScratchRow, rngAddress.Column)
    With Cells(lScratchRow, rngAddress.Column)
        .WrapText = True
        .Rows.AutoFit
        sngNewRowHeight = .RowHeight
        .ClearContents
        .Rows.AutoFit
    End With
    rngAddress.MergeArea.Cells.RowHeight = _
        sngNewRowHeight / rngAddress.MergeArea.Cells.Cells.Count
    
End Sub
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
This seems to work better to determine the scratch row:
lScratchRow = Rows(1).CurrentRegion.Rows.Count + 5
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
Code:
Sub SetMergedCellRowHeight(rngAddress As Range, Optional sDivide As String)
    'For one group of merged cells in a single column
    '  Increase row height of mergearea rows to allow all data in merged cells to be shown
    '  Row heights will not be reduced
    'sDivide determines how mergarea row heights are increased
    ' T, t = Top cell height, B, b = Bottom cell height
    ' Empty or anything else = all heights equally,
    
    Dim lScratchRow As Long
    Dim sngNewRowHeight As Single
    Dim varyAddress As Variant
    Dim lMergedCellCount As Long
    
    lMergedCellCount = rngAddress.MergeArea.Cells.Count
    
    If rngAddress.Cells.Count > 1 Or lMergedCellCount = 1 Then
        MsgBox "Select a single merged cell in a single column."
        GoTo End_Sub
    End If
    
    'Used range would cause creep each run. This should work
    '  to determine scrath row for most worksheets:
    lScratchRow = Rows(1).CurrentRegion.Rows.Count + 5
    
    rngAddress.Copy Cells(lScratchRow, rngAddress.Column)
    With Cells(lScratchRow, rngAddress.Column)
        .WrapText = True
        .Rows.AutoFit
        sngNewRowHeight = .RowHeight
        .ClearContents
        .Rows.AutoFit
    End With
    
    If rngAddress.MergeArea.RowHeight > sngNewRowHeight Then
        MsgBox "Merged cells " & rngAddress.MergeArea.Address(False, False) & _
            " height allows all data to be visible.", , "No adjustment required"
        GoTo End_Sub
    End If
    
    varyAddress = Split(rngAddress.MergeArea.Address(False, False), ":")
    
    rngAddress.MergeArea.Rows.AutoFit
    Select Case sDivide
    Case "T", "t"
        Range(varyAddress(0)).RowHeight = sngNewRowHeight - _
            (lMergedCellCount - 1) * Range(varyAddress(1)).RowHeight
    Case "B", "b"
        Range(varyAddress(1)).RowHeight = sngNewRowHeight - _
            (lMergedCellCount - 1) * Range(varyAddress(0)).RowHeight
    Case Else
    rngAddress.MergeArea.Cells.RowHeight = _
        sngNewRowHeight / lMergedCellCount
    End Select
End_Sub:
    
End Sub
 

izet99

New Member
Joined
Nov 5, 2009
Messages
14

ADVERTISEMENT

pbornemeier

Am I missing something, macro is not coming up under Macro Run dialog box? I try copied to Module, Thisworkbook and sheet code but nothing?

Izet
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
The way I set it up it needs some parameters and so does not show in the Macro dialog box. Here is slightly changed code with another sub that will call it and is visible in the Macro Run dialog:
Code:
Option Explicit
Sub SetSelectedMergeAreaHeight()
    
    Dim rng As Range
    
    Set rng = Selection.Cells(1)
    SetMergedCellRowHeight rng, "D"
    Set rng = Nothing
    
End Sub

Sub SetMergedCellRowHeight(rngAddress As Range, Optional sDivide As String)
    'For one group of merged cells in a single column
    '  Increase row height of mergearea rows to allow all data in merged cells to be shown
    '  Row heights will not be reduced
    'sDivide determines how mergarea row heights are increased
    ' T, t = Top cell height, B, b = Bottom cell height
    ' Empty or anything else = all heights equally,
    
    Dim lScratchRow As Long
    Dim sngNewRowHeight As Single
    Dim varyAddress As Variant
    Dim lMergedCellCount As Long
    
    lMergedCellCount = rngAddress.MergeArea.Cells.Count
    
    If rngAddress.Cells.Count > 1 Or lMergedCellCount = 1 Then
        MsgBox "Select a single merged cell in a single column."
        GoTo End_Sub
    End If
    
    'Used range would cause creep each run. This should work
    '  to determine scratch row for most worksheets:
    lScratchRow = rngAddress.CurrentRegion.Rows.Count + 5
    
    rngAddress.Copy Cells(lScratchRow, rngAddress.Column)
    With Cells(lScratchRow, rngAddress.Column)
        .WrapText = True
        .Rows.AutoFit
        sngNewRowHeight = .RowHeight
        .ClearContents
        .Rows.AutoFit
    End With
    
    If rngAddress.MergeArea.RowHeight > sngNewRowHeight Then
        MsgBox "Merged cells " & rngAddress.MergeArea.Address(False, False) & _
            " height allows all data to be visible.", , "No adjustment required"
        GoTo End_Sub
    End If
    
    varyAddress = Split(rngAddress.MergeArea.Address(False, False), ":")
    
    rngAddress.MergeArea.Rows.AutoFit
    Select Case sDivide
    Case "T", "t"
        Range(varyAddress(0)).RowHeight = sngNewRowHeight - _
            (lMergedCellCount - 1) * Range(varyAddress(1)).RowHeight
    Case "B", "b"
        Range(varyAddress(1)).RowHeight = sngNewRowHeight - _
            (lMergedCellCount - 1) * Range(varyAddress(0)).RowHeight
    Case Else
    rngAddress.MergeArea.Cells.RowHeight = _
        sngNewRowHeight / lMergedCellCount
    End Select
End_Sub:
    
End Sub
 

izet99

New Member
Joined
Nov 5, 2009
Messages
14
Hi Phil,

Thank you for update, I did loaded into module... and I see macro, when I run on my current active sheet, I don't see it expend rows... I see macro is running and doing something but I don't see any change on my merged cells... my merched cell C16:H100

I changed Range to "C", however don't see if I need to change anything else.
Code:
Sub SetSelectedMergeAreaHeight()
    
    Dim rng As Range
    
    Set rng = Selection.Cells(1)
    SetMergedCellRowHeight rng, "C"
    Set rng = Nothing
 
End Sub

Izet
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,889
The code won't work if more than a single column is selected.
I don't see any to speed the operation of the original code you posted.
Sorry to head you down an incorrect path.
 

Watch MrExcel Video

Forum statistics

Threads
1,128,069
Messages
5,628,468
Members
416,319
Latest member
k8o2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top