Speed Up Resize Merged Cell Rows

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Hello and thank you for any attention my post may receive.

I am resizing the height of 10 merged cell rows to fit the formula produced text string. For the purpose of this project I am unable to remove the merged areas.
I found 'ReSizeRow' code, courtesy of Ged Warren Nov 12, 2012, and added my extra merged ranges to it, which gives me my desired outcome, however is rather slow.

I am after any suggestions to speed it up.

The 'ReSizeRow' code is in a module and is called by this Worksheet_Change event.

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Sheets("SwingLog")
Me.Calculate
    If Not Application.Intersect(Target, Range("C6:C7")) Is Nothing Then
        Application.EnableEvents = False
        Call Module9.ReSizeRow
    End If
Application.EnableEvents = True
End Sub


VBA Code:
Public Sub ReSizeRow()
Dim TestWidth As Double
    Dim TestHeight As Double
    Dim Ra, Rb, Rc, Rd, Re, Rf, Rg, Rh, Ri, Rj As Range
    Set Ra = Range("C9:I9")
    Set Rb = Range("C11:I11")
    Set Rc = Range("C13:I13")
    Set Rd = Range("C15:I15")
    Set Re = Range("C17:I17")
    Set Rf = Range("C19:I19")
    Set Rg = Range("C21:I21")
    Set Rh = Range("C23:I23")
    Set Ri = Range("C25:I25")
    Set Rj = Range("C27:I27")
   
 '   If Ra.MergeCells = False Then Exit Sub 
        Ra.WrapText = True
        Ra.UnMerge
        Rows(Ra.Row).AutoFit
        TestWidth = Ra.Width
        TestHeight = Ra.Height
        Ra.Merge
        Ra.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rb.WrapText = True
        Rb.UnMerge
        Rows(Rb.Row).AutoFit
        TestWidth = Rb.Width
        TestHeight = Rb.Height
        Rb.Merge
        Rb.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rc.WrapText = True
        Rc.UnMerge
        Rows(Rc.Row).AutoFit
        TestWidth = Rc.Width
        TestHeight = Rc.Height
        Rc.Merge
        Rc.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rd.WrapText = True
        Rd.UnMerge
        Rows(Rd.Row).AutoFit
        TestWidth = Rd.Width
        TestHeight = Rd.Height
        Rd.Merge
        Rd.RowHeight = TestWidth * TestHeight / TestWidth
    
        Re.WrapText = True
        Re.UnMerge
        Rows(Re.Row).AutoFit
        TestWidth = Re.Width
        TestHeight = Re.Height
        Re.Merge
        Re.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rf.WrapText = True
        Rf.UnMerge
        Rows(Rf.Row).AutoFit
        TestWidth = Rf.Width
        TestHeight = Rf.Height
        Rf.Merge
        Rf.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rg.WrapText = True
        Rg.UnMerge
        Rows(Rg.Row).AutoFit
        TestWidth = Rg.Width
        TestHeight = Rg.Height
        Rg.Merge
        Rg.RowHeight = TestWidth * TestHeight / TestWidth
    
        Rh.WrapText = True
        Rh.UnMerge
        Rows(Rh.Row).AutoFit
        TestWidth = Rh.Width
        TestHeight = Rh.Height
        Rh.Merge
        Rh.RowHeight = TestWidth * TestHeight / TestWidth
        
        Ri.WrapText = True
        Ri.UnMerge
        Rows(Ri.Row).AutoFit
        TestWidth = Ri.Width
        TestHeight = Ri.Height
        Ri.Merge
        Ri.RowHeight = TestWidth * TestHeight / TestWidth

        Rj.WrapText = True
        Rj.UnMerge
        Rows(Rj.Row).AutoFit
        TestWidth = Rj.Width
        TestHeight = Rj.Height
        Rj.Merge
        Rj.RowHeight = TestWidth * TestHeight / TestWidth
End Sub
 

Some videos you may like

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Merged cells are usually a pain in the @#$ ... (as you've discovered).
If you really can't live without it (text alignment feature works fine and does not cause misery...), the adjustments below may provide some relief.

Rich (BB code):
Private Sub Worksheet_Change(ByVal Target As Range)
   
'    Dim ws As Worksheet            '<< not used so superfluous
'    Set ws = Sheets("SwingLog")    '<< not used so superfluous

    Dim xlCalc As XlCalculation
    Me.Calculate
    With Application
        If Not .Intersect(Target, Range("C6:C7")) Is Nothing Then
            xlCalc = .Calculation
            .EnableEvents = False
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
           
            Call Module9.ReSizeRow
           
            .EnableEvents = True
            .Calculation = xlCalc
            .ScreenUpdating = True
        End If
    End With
End Sub
 
Solution

Nadine

New Member
Joined
May 12, 2020
Messages
30
Office Version
  1. 365
Platform
  1. Windows
Firstly, I would like to say a big thank you to GWteB. You have reduced the execution time by more than half and I could not be happier.

and secondly...
Merged cells are usually a pain in the @#$
Yes they surely are.....but once in a while there is a true need for them.

Have a great day!
 

Watch MrExcel Video

Forum statistics

Threads
1,127,256
Messages
5,623,672
Members
415,983
Latest member
MusicMan

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