Unmerge, Sort and Merged cells in vba - vba

Question

I am working with the excel-vba, I have to sort the rows in ascending order with merged cells, I know that the merged cell cannot be sorted that is why, this work around is the only solution to my problem. I need to unmerged the cells then copy the value of the first cell and paste it to the second cell, after that, the code will sort the list using the A column and C column. and then after that if the A and C column has an equal value, it will turn to merged cell.
I hope someone could help me with this project.
Also view this image to see the list.
Sort
So, I constructed a code that will do this process but it cant.
Sub Sort()
On Error GoTo myErr
Dim myRange As Range
Dim lstrow As Long
Dim i As Integer
Dim cel As Range
Set myRange = Sheet1.Range("A2:C7")
lstrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With myRange
.UnMerge
For Each cel In myRange
If IsEmpty(cel) Then
For i = 2 To lstrow
' cel(i).Value = 1
Sheet1.Range(i).Copy Sheet1.Range(cel).PasteSpecial
Sheet1.Range("C3").CurrentRegion.Sort _
key1:=Sheet1.Range("C3"), order1:=xlAscending, _
Header:=xlGuess
Next i
End If
Next cel
End With
myErr:
MsgBox "Unble to sort!"
End Sub
“No one is useless in this world who lightens the burdens of another. -Charles Dickens”
Regards,

Answer 1

If you are going to find lstRow before unmerging, use Column B — if the last row in Column A is merged, then the bottommost cell is empty! Or if you prefer, you can find lstRow after unmerging everything.
By looping through myRange you can both UnMerge any merged cells and populate the newly unmerged cells using the MergeArea.address of the original merged cell. After sorting on columns A and C, you can then loop through those columns, comparing each row to the row beneath. Only re-merge when both the row beneath is the same as the row above for both columns.
Option Explicit
Sub Sort()
Dim myRange As Range
Dim lstrow As Long
Dim l As Long
Dim rng As Range
Dim address As String
Dim contents As Variant
Dim ws As Worksheet
On Error GoTo myErr
Set ws = ThisWorkbook.Sheets("Sheet1")
Set myRange = ws.Range("A1:C7")
' Get lstrow from Column B, if Column A has merged cells
lstrow = ws.Cells(Rows.Count, 2).End(xlUp).Row
' Unmerge and populate
For Each rng In myRange
If rng.MergeCells Then
' Get value from top left cell
contents = rng.MergeArea.Cells(1).Value
address = rng.MergeArea.address
rng.UnMerge
ws.Range(address).Value = contents
End If
Next rng
' Sort
myRange.Sort key1:=ws.Range("A1:A" & lstrow), _
order1:=xlAscending, Header:=xlYes, key2:=ws.Range("C1:C" & lstrow), _
order2:=xlAscending, Header:=xlYes
' Turn off alerts
Application.DisplayAlerts = False
' Re-merge
With ws
For l = 2 To lstrow
If .Cells(l, 1).MergeArea.Cells(1).Value = .Cells(l + 1, 1).MergeArea.Cells(1).Value _
And .Cells(l, 3).MergeArea.Cells(1).Value = .Cells(l + 1, 3).MergeArea.Cells(1).Value Then
' Merge column A
Range(.Cells(l, 1).MergeArea, .Cells(l + 1, 1)).Merge
' Merge column C
Range(.Cells(l, 3).MergeArea, .Cells(l + 1, 3)).Merge
End If
Next l
End With
' Turn on alerts
Application.DisplayAlerts = True
Exit Sub
myErr:
MsgBox "Unable to sort!"
End Sub