wrap text of a sheet with merged and not merged cells - excel

Question

I have a sheet with some cells are merged in rows, and some are not. I want to wrap all the cells and if rows contains merged cells, set the rows height to max of all cells height
In the excel file, you can find the sheet I am working with, what I want to have, the excel macro I wrote, what I get with that macro. I also put them here.
This is what I have: (column D is a hidden column)
This is what I want to have: (for the rest of the sheet see attached excel file)
I wrote an excel VBA macro to do the job, but there is no luck.
Sub MergeCells2()
Application.DisplayAlerts = False
Dim allRange As Range
Dim xCell As Range
On Error Resume Next
Dim i_row As Integer
Dim nRowsToMerge As Integer
Dim rangeToMerge As Range
Worksheets("What I have").Activate
LastCol = ActiveSheet.Range("a1").End(xlToRight).Column
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, LastCol).End(xlUp).Row
Set allRange = Application.Range("a1", ActiveSheet.Cells(LastRow, LastCol))
allRange.WrapText = True
If allRange Is Nothing Then Exit Sub
nRowsToMerge = 1
Set heightToSet = Range("A2").RowHeight
For i_row = 2 To LastRow
Set i_rowRange = allRange.Rows(i_row - 1)
If (allRange.Cells(i_row, 1) = "") Then
nRowsToMerge = nRowsToMerge + 1
ElseIf nRowsToMerge = 1 Then
heightToSet = i_rowRange.RowHeight
Else
Set rangeToMerge = ActiveSheet.Range(ActiveSheet.Cells(i_row - nRowsToMerge, 1), ActiveSheet.Cells(i_row - 1, LastCol))
For Each xCell In rangeToMerge
cellrow = xCell.Row
If (rangeToMerge.Cells(cellrow, 1) = "") Then
If xCell.Value = "" Then
Range(xCell, xCell.Offset(-1, 0)).Merge
End If
End If
Next
rangeToMerge.RowHeight = heightToSet
heightToSet = i_rowRange.RowHeight
nRowsToMerge = 1
End If
Next i_row
End Sub
This is what I get:
I don't know what is wrong with it and I have to say that I don't know much about VBA programming.
I hope I was clear with my question.
Please help, I am working on this for days now :(
Cheers,
Eda

Answer 1

The idea:
Start by wrapping all cells, and using AutoFit for all rows. This way Excel will automatically set the row height properly.
Loop through the rows merging the cells and dividing the height of the row with the wrapped text over the rows to be merged.
This is how:
Sub NewMerger()
Dim r As Long, rMax As Long, re As Long, cMax As Long, c As Long, n As Long, h As Single, mr As Long
Application.DisplayAlerts = False
'Create a copy of the input
Sheets("What I have").Copy After:=Sheets(Sheets.Count)
On Error Resume Next
Sheets("New Result").Delete
ActiveSheet.Name = "New Result"
'merge and use autofit to get the ideal row height
Cells().WrapText = True
Rows.AutoFit
'get max row and column
cMax = Cells(1, 1).End(xlToRight).Column
rMax = Cells(Rows.Count, 1).End(xlUp).Row
'loop through rows, bottom to top
For r = rMax To 2 Step -1
If Cells(r, 1).Value = "" Then
If re = 0 Then re = r 'If we don't have an end row, we do now!
ElseIf re > 0 Then 'If re has an end row and the current row is not empty (AKA start row)
h = Rows(r).RowHeight 'Get the row height of the start row
n = re - r + 1 'calculate the number of rows
If n > 0 Then Rows(r & ":" & re).RowHeight = h / n 'devide the row hight over all rows
For c = 1 To cMax 'And merge
For mr = re To r Step -1 'Merge only empty cells
If Cells(mr, c).Value = "" Then
Range(Cells(mr, c), Cells(mr - 1, c)).MergeCells = True
End If
Next
Next
re = 0 'We don't have an end row now
End If
Next
Application.DisplayAlerts = True
End Sub