VBA code to automatically adjust row height to fit varying lengths of text in merged cells

[AmeliaBedelia]

Hello,
I am running into a problem with finding a resolution to automatically auto fit the row height to varying lengths of text in merged cells. I have tried different VBA code that I have taken right from other forum questions on this and other sites. I have found that for most of the code for this topic, you are telling Excel the height you wan the row to be, not looking at the text in the cell and the auto fitting to that height. For example, the code tells it to double the row height. The problem is, for in my worksheet the text height may vary from one user to another and I require VBA code that will tell Excel to look at the text placed in that cell and automatically auto adjust to whatever text is placed in it. For example, if one time the text is only one row height, leave the row height as it is. The next time the user uses the worksheet the text is 3 row heights, adjust the height to fix the text.

I have used the following code in my module, however it only adjusts the height of each row to the height of two rows:


Call AutoFitMergedCells(Range("WKReportCompStart"))
Call AutoFitMergedCells(Range("WKReportCompStart").Offset(1, 2))
Call AutoFitMergedCells(Range("WKReportCompStart").Offset(2, 2))
Call AutoFitMergedCells(Range("WKReportCompStart").Offset(3, 2))


(The above Call functions are part of another piece of code under a Sub directly above the AutoFitMergedCells Sub below. "WKReportCompStart" is the named range where I want it to start calling the AutoFitMergedCells sub and work its way down to the rows below.)

Public Sub AutoFitMergedCells(oRange As Range)

  Dim tHeight As Integer
  Dim iPtr As Integer
  Dim oldHeight As Single
  Dim oldZZHeight As Single
  Dim newHeight As Single
  Dim newWidth As Single
  With Sheets("PSOPh1_WeeklyReport")
    oldHeight = 0
    For iPtr = 1 To oRange.Rows.Count
    oldHeight = oldHeight + .Cells(1, oRange.row + iPtr - 1).RowHeight
    Next iPtr
    oldHeight = .Cells(1, oRange.row).RowHeight + .Cells(1, oRange.row + 1).RowHeight
    oRange.MergeCells = False
    newHeight = Len(.Cells(oRange.Column, oRange.row).Value)
    oldZZHeight = .Range("ZZ1").RowHeight
    .Range("ZZ1") = Left(.Cells(oRange.row, oRange.row).Value, newHeight)
    .Range("ZZ1").WrapText = True
    .Rows("1").RowHeight = oldHeight
    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").RowHeight = oldZZHeight
  End With
 End Sub

I have also attempted to use the code below, which claims to auto adjust to the length of the text. I added it to the Worksheet, however I have other Worksheet_ChangeSelection code in the same worksheet. I added this code into the Worksheet_ChangeSelection code as well as tried to run it as its own Sub, but nothing changed in the worksheet. I also added it to the module where I had placed the code I provided above, but when it got to "If Not Intersect(Target, Range(str01)) Is Nothing Then" a run-time error message appeared "Run-time error '424' Object Required". I am not sure if this is the code I seek and I just am not inserting it accurately into either my worksheet or my module.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim MergeWidth As Single
 Dim cM As Range
 Dim AutoFitRng As Range
 Dim CWidth As Double
 Dim NewRowHt As Double
 Dim str01 As String
 str01 = "WKReportCompStart"
  If Not Intersect(Target, Range(str01)) Is Nothing Then
    Application.ScreenUpdating = False
    On Error Resume Next
    Set AutoFitRng = Range(Range(str01).MergeArea.Address)
    With AutoFitRng
      .MergeCells = False
      CWidth = .Cells(1).ColumnWidth
      MergeWidth = 0
      For Each cM In AutoFitRng
          cM.WrapText = True
          MergeWidth = cM.ColumnWidth + MergeWidth
      Next
      'small adjustment to temporary width
      MergeWidth = MergeWidth + AutoFitRng.Cells.Count * 0.66
      .Cells(1).ColumnWidth = MergeWidth
      .EntireRow.AutoFit
      NewRowHt = .RowHeight
      .Cells(1).ColumnWidth = CWidth
      .MergeCells = True
      .RowHeight = NewRowHt
    End With
    Application.ScreenUpdating = True
  End If
 End Sub

I am hoping that someone might be able to assist with this. If you need more information, please let me know. This is my first post - so apologies if I have not explained my situation well enough.

 

[mole999]

Do you have to use merged cells, have you tried centre across selection which causes less issues

 

[AmeliaBedelia]

I do not need to use merged cells, however I do need the text to be left aligned as the text being placed in these rows forms a list of comments.

The centre across selection works, but it is center aligned and creates a bit of a messy list. So thank you for the suggestion - this was something I had learned about at some point, but completely forgot existed
Any suggestions so that the text can remain left aligned, but auto-adjust the row height to fit the text?

 

[AmeliaBedelia]

Wondering if anyone else has a solution for this issue???

I might be asking for the impossible