Speed Up Resize Merged Cell Rows

[Nadine]

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.

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

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

 

[GWteB]

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.

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

 

[Nadine]

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!