wrap text of a sheet with merged and not merged cells

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

user_10022961 · Answer

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

wrap text of a sheet with merged and not merged cells

1 Answers