VBA - need autofit row height work around for merged cells

[trillium]

Hi! Apparently I am trying the impossible... I have a spreadsheet that yes, has merged cells (for presentation reasons, I can't change that) and some places need text inserted. WHen I create the "final copy" I need to be sure all text entered can be viewed (because the sheet will then be protected from further edits).

I had come across the following code as a work around

Sub AutoFitMergedCellRowHeight()
    Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
    Dim CurrCell As Range
    Dim ActiveCellWidth As Single, PossNewRowHeight As Single
    If ActiveCell.MergeCells Then
       With ActiveCell.MergeArea
            If .Rows.Count = 1 And .WrapText = True Then
                Application.ScreenUpdating = False
                CurrentRowHeight = .RowHeight
                ActiveCellWidth = ActiveCell.ColumnWidth
                For Each CurrCell In Selection
                    MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
                Next
                .MergeCells = False
                .Cells(1).ColumnWidth = MergedCellRgWidth
                .EntireRow.AutoFit
                PossNewRowHeight = .RowHeight
                .Cells(1).ColumnWidth = ActiveCellWidth
                .MergeCells = True
                .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
                 CurrentRowHeight, PossNewRowHeight)
            End If
        End With
    End If
End Sub

however, I can't for the life of me get it to work in my case!

Is there maybe another way? Or is there something else I can do instead? Insert a word doc? I don't know! grasping at straws where....

Thanks in adavnce for your suggestions.

 

[Ruddles]

I wrote this for someone else - you're welcome to try it. Set oRange to the range of your merged cells and make sure you've got nothing valuable in cell ZZ1: if you do, change the references to ZZ to a suitably enpty cell.

Option Explicit
 
Public Sub AutoFitMergedCells()
 
  Dim oRange As Range
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  
  Set oRange = Range("[COLOR=red][B]A14:B24[/B][/COLOR]")
  oldWidth = 0
  For iPtr = 1 To oRange.Columns.Count
    oldWidth = oldWidth + Cells(1, oRange.Column + iPtr - 1).ColumnWidth
  Next iPtr
  oldWidth = Cells(1, oRange.Column).ColumnWidth + Cells(1, oRange.Column + 1).ColumnWidth
  oRange.MergeCells = False
  newWidth = Len(Cells(oRange.Row, oRange.Column).Value)
  oldZZWidth = Range("[COLOR=red][B]ZZ[/B][/COLOR]1").ColumnWidth
  Range("[COLOR=red][B]ZZ[/B][/COLOR]1") = Left(Cells(oRange.Row, oRange.Column).Value, newWidth)
  Range("[COLOR=red][B]ZZ[/B][/COLOR]1").WrapText = True
  Columns("[COLOR=red][B]ZZ[/B][/COLOR]").ColumnWidth = oldWidth
  Rows("1").EntireRow.AutoFit
  newHeight = Rows("1").RowHeight / oRange.Rows.Count
  Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
  oRange.MergeCells = True
  oRange.WrapText = True
  Range("[B][COLOR=red]ZZ[/COLOR][/B]1").ClearContents
  Range("[COLOR=red][B]ZZ[/B][/COLOR]1").ColumnWidth = oldZZWidth
  
End Sub

 

[trillium]

THANK YOU for your reply! I'm trying it now, but I'm getting an error message at this line

  oldZZWidth = Range("ZZ1").ColumnWidth

Its a Runtime 1004
Method Range' of object'_ Global' failed

?? would you know why?
I insered the code right into my macro to create the final copy. Should I have it somewhere else and just call the macro?

 

[Ruddles]

It was written to stand on its own, so it could be run by the user or called from another macro. Place it in your worksheet code module and test it by running it on its own before you try modifying anything.

Presumably you put the range of your merged cell in where my code was Set oRange = Range("A14:B24")?

 

[Ruddles]

Okay, maybe I should refer to the sheet explicitly. Change the sheet name and range and try this:-

Option Explicit
 
Public Sub AutoFitMergedCells()
 
  Dim oRange As Range
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  
  With Sheets("[COLOR=red][B]Sheet1[/B][/COLOR]")
    Set oRange = .Range("[COLOR=red][B]A14:B24[/B][/COLOR]")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
  End With
    
End Sub

 

[trillium]

Thanks Ruddles! I was out last night. I did question myself when I saw the Option Explicit... but I'm still fairly new to macros ... I will try your new suggestion right now!

 

[trillium]

hmmm???

OK, so I put it into my wks. I ran it from there. Now I'm getting a "Run Time Error 9, Subspript of Range"?

I have several ranges to be checked... could that be the problem? Should I just say, check the whole sheet?

With Sheets("Sheet2")
  Set oRange = Range("C12:C14,G12:G14,D21:D66,C69:C76")

 

[Ruddles]

No, the routine just does one merged cell each time you call it but it does this by adjusting the height of the rows, so if you call it with the ranges you've indicated - with overlapping rows - it will adjust the height of rows 12-14 to 'autofit' the first range C12:C14 and then adjust them again for G12:14, so the change it did for C12:C14 will be lost.

If you want to call it with multiple cells, you'll have to do something like this:-

Option Explicit
 
Public Sub AutoFitAll()
  
  Call AutoFitMergedCells(Range("C12:C14"))
  Call AutoFitMergedCells(Range("D21:D66"))
  Call AutoFitMergedCells(Range("C69:C76"))
 
End Sub
 
Public Sub AutoFitMergedCells(oRange As Range)
 
  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldWidth As Single
  Dim oldZZWidth As Single
  Dim newWidth As Single
  Dim newHeight As Single
  
  With Sheets("Sheet1")
    oldWidth = 0
    For iPtr = 1 To oRange.Columns.Count
      oldWidth = oldWidth + .Cells(1, oRange.Column + iPtr - 1).ColumnWidth
    Next iPtr
    oldWidth = .Cells(1, oRange.Column).ColumnWidth + .Cells(1, oRange.Column + 1).ColumnWidth
    oRange.MergeCells = False
    newWidth = Len(.Cells(oRange.Row, oRange.Column).Value)
    oldZZWidth = .Range("ZZ1").ColumnWidth
    .Range("ZZ1") = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth)
    .Range("ZZ1").WrapText = True
    .Columns("ZZ").ColumnWidth = oldWidth
    .Rows("1").EntireRow.AutoFit
    newHeight = .Rows("1").RowHeight / oRange.Rows.Count
    .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight
    oRange.MergeCells = True
    oRange.WrapText = True
    .Range("ZZ1").ClearContents
    .Range("ZZ1").ColumnWidth = oldZZWidth
  End With
    
End Sub

This may not be the solution you're looking for...

 

[seanpears99]

This is an old thread I know but I need to use something similar. I also have some merged cells and have two ranges to check, would it not be best to count the number of characters if the ranges are of similar size and apply the autofit to that range only for the largest character count.