Hi All,

I modify the codes, which will search the merged cells and apply the autofit. hope this will help the future if any one interested.


Sub FindMergedCells()

' Declare sheet you want to look for merged cells on - in the example it's sheet 1
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets(1)
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Dim tHeight As Integer
Dim iPtr As Integer
Dim oldWidth As Double
Dim oldZZWidth As Double
Dim newWidth As Double
Dim newHeight As Double
Dim oRange As Range


' Add sheet for output
Dim output As Worksheet
Set output = Sheets.Add(after:=Sheets(1))

' Initialize row counter for output
orow = 0

' Header on output sheet


' Check all the cells in the worksheet's used range
For Each cell In sheet.UsedRange

' If they're merged -

If cell.MergeCells Then
orow = orow + 1
Set cell = cell.MergeArea
Set rngStart = cell.Cells(1, 1)
Set rngEnd = cell.Cells(cell.Rows.Count, cell.Columns.Count)

'MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
'output.Cells(orow, 1) = "" & Replace(rngStart.Address, "$", "") & ":" & Replace(rngEnd.Address, "$", "")
Set oRange = Range("" & Replace(rngStart.Address, "$", "") & ":" & Replace(rngEnd.Address, "$", ""))

With sheet
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
Else

'MsgBox "Not merged area"

End If
Next cell

End Sub

There is a limit on the size - if the total height required is greater than 409.5, it will only do what would fit in 409.5 and spread it amongst the height of the merged cells and you would not see the remainder.  I was hoping this would solve for text lengths greater than the max row height (409.5).  I think you may need to iterate through and split the text to what can fit in to the first max height of 409.5 then put the rest in another cell (ZZ2) and so on until it fits, then count the rows in each cell then get the total required height.

Dang it, copy/paste bit me. Also, with explicit sheet references the With isn't needed:

Public Sub AutoFitMergedCells(oRange As Range, ByVal dblWidth As Double)



oRange.MergeCells = False

Sheet1.Range("A1") = oRange.Cells(1, 1).Value

Sheet1.Range("A1").WrapText = True

Sheet1.Columns(1).ColumnWidth = dblWidth

Sheet1.Rows(1).EntireRow.AutoFit

oRange.Parent.Rows(oRange.Row).Resize(oRange.Rows.Count).RowHeight _

= Sheet1.Rows(1).RowHeight / oRange.Rows.Count

oRange.MergeCells = True

oRange.WrapText = True



End Sub

Thank you, that helped me with a sheet I've not been happy with for years.

I did change things around a bit, my merged cells are all in one column so I calculated that outside the loop and passed it. I also inserted a Sheet1 that is hidden, and manipulated the columns/rows there so as to not affect the sheet I'm working on. The references should probably be more explicit:

Public Sub AutoFitMergedCells(oRange As Range, ByVal dblWidth As Double)



Dim dblHeight As Double



With oRange.Parent

oRange.MergeCells = False

Sheet1.Range("A1") = oRange.Cells(1, 1).Value

Sheet1.Range("A1").WrapText = True

Sheet1.Columns(1).ColumnWidth = dblWidth

Sheet1.Rows(1).EntireRow.AutoFit

dblHeight = Sheet1.Rows(1).RowHeight / oRange.Rows.Count

oRange.Parent.Rows(oRange.Row).Resize(oRange.Rows.Count).RowHeight = newHeight

oRange.MergeCells = True

oRange.WrapText = True

Sheet1.Range("A1").ClearContents

End With



End Sub

This not work for me}

not working , ye password set in your code not working in your code

I believe the reason that the row heights do not calculate properly is related to these lines of code
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

The variable OldWidth gets set to the sum of the column widths in the range, but for some reason it gets reset to only the width of the first two columns. The first 3 lines of code are therefore made redundant by the 4th line. When I removed the line it was much better, but the other issue I found was that you have to make sure that the font and font size of the temporary cell (ZZ1 in the example code) must match the font and size of the merged cells; otherwise, text will not wrap in the same way as the merged cells wrap and may not be the correct height.

I am trying to understand the necessity of Line 19. You are assigning a value again to OldWidth. Can you please explain?

My code will not even run I just get a compile error when I try to call the AutoFitMergedCells - Expected Function or variable?

Because the "helper" cell of ZZ1 is using the first row (column ZZ, row 1), if there is ANYTHING in row 1 taller than the text in the row you want to adjust, your resulting height will be taller than what you want. To fix this, I made the helper cell the same column as the first column in the oRange and set the row number to the very last row in Excel. Hope this helps you like it does me. 8) My Code: Option Explicit Public Sub AutoFitAll() Call AutoFitMergedCells(Range("A2:Z2")) 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 = .Cells("1048576", oRange.Column).ColumnWidth .Cells("1048576", oRange.Column) = Left(.Cells(oRange.Row, oRange.Column).Value, newWidth) .Cells("1048576", oRange.Column).WrapText = True .Columns(oRange.Column).ColumnWidth = oldWidth .Rows("1048576").EntireRow.AutoFit newHeight = .Rows("1048576").RowHeight / oRange.Rows.Count .Rows(CStr(oRange.Row) & ":" & CStr(oRange.Row + oRange.Rows.Count - 1)).RowHeight = newHeight oRange.MergeCells = True oRange.WrapText = True .Cells("1048576", oRange.Column).ClearContents .Cells("1048576", oRange.Column).ColumnWidth = oldZZWidth End With End Sub

Thank you for the code. However, the height of my rows do adjust, but now enough. How can I rectify this?

Thanks for posting this, I'm decent with excel and can usually figure out my adjustments but I can't seem to figure out a fix for an issue I'm having, or if one even exists. I have huge amounts of data in the cells (exceeding the single cell height limit of 409.5). The problem is this VBA runs with that same limitation. So some of my data gets cut off even though the rows are merged and the combined cell height allowance is 819, since the VBA adjusts the cell height based off the single ZZ1 cell. Is there anyway to adjust the code to get it to allow the adjusted cell height to include the available height in the merged rows or am I asking for the impossible? Thanks.

Works perfect, but rows are too high! Can we fix this?

Brilliant but exactly the same problem as Danielle, rows are too high now. Please someone help!

Thanks so much for the code. Is there any way to make the macro run as soon as you type text in a field and hit enter?

Thanks for the code, pretty much what I needed. Two remarks, though: 1) when I run the macro in the same row as the "helper"cell (ZZ1), autofit (line 26) will mess up, because the whole string is fitted into one narow cell. I recommend adding oRange.WrapText = False in the beginning (or moving the helper cell somewhere out of the way, if possible). 2) what's the purpose of line 19? You claculate oldWidth in lines 16-18, but then override the calculation in line 19, using only two columns. When I tried the sub on a three-column-wide merged cells, it worked better when I ignored the line... Thanks again

Thanks a lot for the code! I have same problem with this code such as DANIËLLE_01.

Thanks a lot for the code! It finally works, but... My row height becomes too height. Is there a solution for? Thanks a lot! This is my code: Option Explicit Public Sub AutoFitAll() Call AutoFitMergedCells(Range("b162:i162")) Call AutoFitMergedCells(Range("b166:i166")) Call AutoFitMergedCells(Range("b168:i168")) Call AutoFitMergedCells(Range("b170:i170")) Call AutoFitMergedCells(Range("b172:i172")) 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("Rapport") 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

I have the following entered, but I get an error message "Run-time error '13': Type mismatch" Help? Option Explicit Public Sub AutoFitAll() Call AutoFitMergedCells(Range("a8:h8")) Call AutoFitMergedCells(Range("a10:h10")) Call AutoFitMergedCells(Range("a11:h11")) Call AutoFitMergedCells(Range("b17:h17")) Call AutoFitMergedCells(Range("b22:h22")) Call AutoFitMergedCells(Range("b24:h24")) Call AutoFitMergedCells(Range("a26:h26")) Call AutoFitMergedCells(Range("a28:h28")) 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("Offer Letter") 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 code causes additional rows to be deleted. I have numbers on left side and columns next to it are merged/wrapped data. For example, in a Job description, list responsibilities with numbers followed by explanation of duty. Any thoughts? Thanks.