Current VBA very slow in deleting merged cells

[Livin404]

Greetings, I have a VBA which does work, but it is incredible slow. I'm trying to delete rows containing merged cells. The name of the work sheet is "Database". Any suggestions to speed this process along? Thank you,

Sub DeleteMergedCells()
Dim w As Worksheet
Dim r As Range
Application.DisplayAlerts = False
For Each w In Worksheets
    If w.Name <> "x" And w.Name <> "y" Then
        With w
            For Each r In .UsedRange
                If r.MergeCells Then r.Delete
            Next r
        End With
    End If
Next w
Application.DisplayAlerts = True
End Sub

 

[EXCEL MAX]

Hello Livin404,
suppose your code looping through big size of ranges.
Try ...

ActiveSheet.UsedRange.Clear

 

[mohadin]

May be
Try

Sub DeleteMergedCells()
    Dim w As Worksheet
    Dim r, rr As Range
    Dim rrr As Range
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    For Each w In Worksheets
        If w.Name <> "x" And w.Name <> "y" Then
            With w
                For Each r In .UsedRange
                    If r.MergeCells Then
                        If rr Is Nothing Then
                            Set rr = r
                        Else
                            Set rrr = r
                            Set rr = Union(rrr, rr)
                        End If: End If
                Next
                rr.Delete
            End With
        End If
    Next w
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

 

[EXCEL MAX]

Or...

ActiveSheet.UsedRange.ClearFormats

 

[Fluff]

If you just want to unmerge the cells, rather than delete them

For Each W In Worksheets
    If W.Name <> "x" And W.Name <> "y" Then
        W.UsedRange.UnMerge
    End If
Next W

 

[Livin404]

If you just want to unmerge the cells, rather than delete them

For Each W In Worksheets
    If W.Name <> "x" And W.Name <> "y" Then
        W.UsedRange.UnMerge
    End If
Next W

Thank you that was my best choice. The VBA I had to follow was one to delete a row that contains a specific word and all the following rows. The problem was the VBA wasn't allowing me to do so on merged cells. With your VBA it works great now thank you. The VBA that follows yours is:

Sub Delete_Totals()
Dim LR As Long, Found As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
Set Found = Columns("A").Find(what:="*passenger*", LookIn:=xlValues, lookat:=xlWhole)
If Not Found Is Nothing Then Rows(Found.Row & ":" & LR).Delete
End Sub

 

[Fluff]

Glad we could help & thanks for the feedback.