VBA code to Delete unmerge cells and keep data

[Kurt]

I have found the following code which does the first part perfectly

Sub FindMerged2()
'http://www.extendoffice.com/documents/excel/962-excel-select-merged-cells.html
Dim c As Range
    For Each c In ActiveSheet.UsedRange
    If c.MergeCells Then
        c.Interior.ColorIndex = 36
    End If
Next
End Sub
Sub FindMerged4()
Dim c As Range
Dim sMsg As String
sMsg = ""
    For Each c In ActiveSheet.UsedRange
        If c.MergeCells Then
            If sMsg = "" Then
                sMsg = "Merged worksheet cells:" & vbCr
            End If
                sMsg = sMsg & Replace(c.Address, "$", "") & vbCr
        End If
Next
        If sMsg = "" Then
            sMsg = "No merged worksheet cells."
        End If
MsgBox sMsg
End Sub

Now what is the best way to use the unmerge command in vba to make the merged cells in column A one cell and keep the rest of the data?

 

[SpreedsheetCrusader]

if you have a sample file or data that would help.

dunno usually when you Unmerge cells in VBA the data is retained, it does not go anywhere.

am saying this because i was solving something for a dude here in the forum this morning he had a problem with UnMergin some merged cells and changing their content. find the file below

http://www.filedropper.com/searchreplaceandunmerge

 

[Kurt]

Hello SpreedsheetCrusder,

Please check your PM.

Thanks,

Kurt

 

[Kurt]

Many thanks and hats off to Smitty for providing the answer.

Be sure to change the range to your particular needs:

Sub Get_Merged_Cells_Delete_Blanks2()
    Dim lr As Long
   
    Sheets("Sheet1").Copy After:=Sheets(3)
   
    With ActiveSheet
        lr = Cells(Rows.Count, "A").End(xlUp).Row
        With Range("$A$2:$Y$" & lr)
            .UnMerge
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:="="
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
        End With
    End With
   
End Sub

Awesome quick answer Smitty!

 

[Kurt]

Many thanks and hats off to Smitty for providing the answer.

Be sure to change the range to your particular needs:

Sub Get_Merged_Cells_Delete_Blanks2()
    Dim lr As Long
   
    Sheets("Sheet1").Copy After:=Sheets(3)
   
    With ActiveSheet
        lr = Cells(Rows.Count, "A").End(xlUp).Row
        With Range("$A$2:$Y$" & lr)
            .UnMerge
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:="="
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilter
        End With
    End With
   
End Sub

Awesome quick answer Smitty!

Use this code to make sure the Auto Filter is turned off:

Sub Get_Merged_Cells_Delete_Blanks2()
    Dim lr As Long
   
    Sheets("Sheet1").Copy After:=Sheets(3)
   
    With ActiveSheet
        lr = Cells(Rows.Count, "A").End(xlUp).Row
        With Range("$A$2:$Y$" & lr)
            .UnMerge
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:="="
            .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
    End With
    If ActiveSheet.FilterMode = True Then
        Selection.AutoFilter
    End If
End Sub

Again many thanks Smitty!