CODEWITHSUNDEEP
vbaexcel
user9663005
user9663005

Reputation:

Unmerge, Sort and Merged cells in vba

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,

Upvotes: 0

Views: 1933

Answers (1)

BigBen
BigBen

Reputation: 49998

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

Upvotes: 1

Related Questions