Auto adjust cell height (or row height) for adjacent merged cells

[Excelbuddy_7]

Hi

I have a table with 11 columns. I had to use merged cells in the table. Now I want to be able to auto-adjust the cell height (row height), with excel taking into account all the columns and set the cell height.

REQUIRED: Can excel take into account the data in the row, and auto adjust the cell height. It only needs to check the C, V, AP and CE columns in the pic (example table; columns alphabets are far apart because of merged cells). The columns in red are a dropdown list (for info).

CURRENT SITUATION: At the moment I have a code, which checks the cells required, but only in the particular order in the code. For example, first it checks C13, then it checks V13. (default cell height is so 1 line of text can be visible). Now when data in C13 is more than one line, it doesn't change the cell height because V13 (which has no data typed in yet) is only 1 line high (and it checks V13 after C13).

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rChanged As Range, c As Range
  
  'Set a range equal to all the changed cells in the range (there could be more than one at a time)
  Set rChanged = Intersect(Target, Range("BD11:BP34"))
  
  'If something did change in the range then
  If Not rChanged Is Nothing Then
    
    'Disable events so when/if we change acell on the sheet this whole code doesn't get called again
    Application.EnableEvents = False
    
    'Work through each of the column D changed cells
    For Each c In rChanged
      
      'Add a "-" at the end of the cell value then split that result into bits by dividing it up at each "-"
      'This creates an array of 'bits', the first of which is referenced by zero (0)
      'Take that first 'bit', trim off any leading/trailing spaces & put that value in the cell
      c.Value = Trim(Split(c.Value & "-", "-")(0))
      
    'Repeat for other changed cells in the column
    Next c
    
    'Re-enable events ready for the next change to the worksheet
    Application.EnableEvents = True
  End If
  
  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
'Cell Ranges below, change to suit.
ar = Array("C12", "C13", "V13", "C11")
For i = 1 To UBound(ar)
    On Error Resume Next
    Set rng = Range(Range(ar(i)).MergeArea.Address)
    With rng
      .MergeCells = False
      cw = .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
      .Cells(1).ColumnWidth = mw
      .EntireRow.AutoFit
      rwht = .RowHeight
      .Cells(1).ColumnWidth = cw
      .MergeCells = True
      .RowHeight = rwht
    End With
Next i
    Application.ScreenUpdating = True
End Sub

The first bit of code is from "http://www.mrexcel.com/forum/excel-questions/900007-replace-text-selected-drop-down-list-number-same-cell.html". (It is so the data from my drop down lists can be converted to just a number for future use).

The second bit of code (for adjusting cell height), was from another website.

Also at the moment, the first bit of code takes a long time to work as it is also adjusting the cell height after sorting out my dropdown lists. Is there any way to change this?

Another issue at the moment: In my array in the second code (C12, C13, V13, C11), for some reason the code doesn't work for the cell in the first position in the array (in this case C12).


Sorry if it is a bit confusing; hope it all makes sense. Please let me know if you need any more information.

Thanks for any help.

 

[Fishboy]

C, V, AP, CE

Thanks

Hmm, having recreated your setup (so....many....merged....cells....!) I wrote the following code which in theory should have done the job:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Or Target.Column = 22 Or Target.Column = 42 Or Target.Column = 83 Then
Target.EntireRow.AutoFit
End If
End Sub

Unfortunately that didn't work and I have my suspicions that it could be down to all those merged cells. I am hoping maybe Peter_SSs pops his head in here again as I would be interested to hear his thoughts on the above.

 

[Excelbuddy_7]

Hmm, having recreated your setup (so....many....merged....cells....!) I wrote the following code which in theory should have done the job:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Or Target.Column = 22 Or Target.Column = 42 Or Target.Column = 83 Then
Target.EntireRow.AutoFit
End If
End Sub

Unfortunately that didn't work and I have my suspicions that it could be down to all those merged cells. I am hoping maybe Peter_SSs pops his head in here again as I would be interested to hear his thoughts on the above.

Thanks Fishboy for giving it a go. Highly appreciated. Lets see if anyone else has any more thoughts. Did you get a chance to take a look at this link: Excel VBA, Dashboards, Charting, Financial modelling and more... ?

 

[Fishboy]

Thanks Fishboy for giving it a go. Highly appreciated. Lets see if anyone else has any more thoughts. Did you get a chance to take a look at this link: Excel VBA, Dashboards, Charting, Financial modelling and more... ?

Hmmm, that link is actually pretty cool, and it certainly works as a standalone macro. I updated it to suit your data and it still works on the press of a button.

Sub FixMerged() 'Excel VBA to autofit merged cells
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
'Cell Ranges below, change to suit.
ar = Array("C" & ActiveCell.Row, "V" & ActiveCell.Row, "AP" & ActiveCell.Row, "CE" & ActiveCell.Row)
 
       For i = 0 To UBound(ar)
           On Error Resume Next
           Set rng = Range(Range(ar(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

The next thing I tried was writing the following worksheet_change event macro.....

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Or Target.Column = 22 Or Target.Column = 42 Or Target.Column = 83 Then
Call FixMerged
End If
End Sub

...which unfortunately didn't work.

Annoyingly enough if you create a dummy macro as below:

Sub TEST()
MsgBox "TEST"
End Sub

And then update the change event to this...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Or Target.Column = 22 Or Target.Column = 42 Or Target.Column = 83 Then
Call TEST
End If
End Sub

...that works. I cannot quite get my head around why I can call this simple sub from the change event but the more complicated one doesn't do anything....

 

[Excelbuddy_7]

Hmmm, that link is actually pretty cool, and it certainly works as a standalone macro. I updated it to suit your data and it still works on the press of a button.

That is a pretty good link yeah, you can also take a look at the original Contextures blog. Also did you try looking at this code from that link (it says it is for 'Fit Row Height to Largest Text):

Option Explicit 'Excel VBA to fit row height to the largest amount of text in that row.

Sub MergedAreaRowAutofit()
    Dim j As Long
     Dim n As Long
     Dim i As Long
     Dim MW As Double 'merge width
     Dim RH As Double 'row height
     Dim MaxRH As Double
     Dim rngMArea As Range
     Dim rng As Range
      
     Const SpareCol  As Long = 26
     Set rng = Range("C10:O" & Range("C" & Rows.Count).End(xlUp).Row)
     
     With rng
         For j = 1 To .Rows.Count
              '//if the row is not hidden
             If Not .Parent.Rows(.Cells(j, 1).Row).Hidden Then
                  'if the cells have data
                 If Application.WorksheetFunction.CountA(.Rows(j)) Then
                     MaxRH = 0
                     For n = .Columns.Count To 1 Step -1
                         If Len(.Cells(j, n).Value) Then
                              'mergecells
                             If .Cells(j, n).MergeCells Then
                                 Set rngMArea = .Cells(j, n).MergeArea
                                 With rngMArea
                                     MW = 0
                                     If .WrapText Then
                                          '//get the total width
                                         For i = 1 To .Cells.Count
                                             MW = MW + .Columns(i).ColumnWidth
                                         Next
                                         MW = MW + .Cells.Count * 0.66
                                          'use the spare column and put the value, make autofit, get the row height
                                         With .Parent.Cells(.Row, SpareCol)
                                             .Value = rngMArea.Value
                                             .ColumnWidth = MW
                                             .WrapText = True
                                             .EntireRow.AutoFit
                                             RH = .RowHeight
                                              'store the max row height for this row
                                             MaxRH = Application.Max(RH, MaxRH)
                                             .Value = vbNullString
                                             .WrapText = False
                                             .ColumnWidth = 8.43
                                         End With
                                         .RowHeight = MaxRH
                                     End If
                                 End With
                             ElseIf .Cells(j, n).WrapText Then
                                 RH = .Cells(j, n).RowHeight
                                 .Cells(j, n).EntireRow.AutoFit
                                 If .Cells(j, n).RowHeight < RH Then .Cells(j, n).RowHeight = RH
                            End If
                         End If
                     Next
                 End If
             End If
         Next
         .Parent.Parent.Worksheets(.Parent.Name).UsedRange
    End With
 End Sub

It is too much for me to try and wrap my head around it.

...that works. I cannot quite get my head around why I can call this simple sub from the change event but the more complicated one doesn't do anything....

It is pretty weird, if one macro works you would expect another one to work as well. But I really appreciate you trying to help me. Thanks a lot

Hopefully someone can help us out.