Option Explicit

Function Ununion(rSource As Range, rExclude As Range) As Range
    Dim nRow As Long, nCol As Long
    Dim nTop As Long, nBottom As Long
    Dim nLeft As Long, nRight As Long
    Dim MaxRow As Long, MaxCol As Long
    Dim ws As Worksheet
    Dim rExt(1 To 4) As Range
    Dim rRev As Range, rRet As Range, r As Range
    Dim i As Integer

    If rSource Is Nothing Then Exit Function
    If rExclude Is Nothing Then
        Set Ununion = rSource
        Exit Function
    End If

    Set ws = rSource.Worksheet
    If ws.Name <> rExclude.Worksheet.Name Or _
        ws.Parent.Name <> rExclude.Worksheet.Parent.Name Then
        Set Ununion = rSource
        Exit Function
    End If

    MaxRow = ws.Rows.Count
    MaxCol = ws.Columns.Count

    For Each r In rExclude.Areas
        nRow = r.Rows.Count
        nCol = r.Columns.Count
        nTop = r.Row
        nBottom = nTop + nRow - 1
        nLeft = r.Column
        nRight = nLeft + nCol - 1

        For i = 1 To 4
            Set rExt(i) = Nothing
        Next
        If nTop > 1 Then
            Set rExt(1) = ws.Rows(1).Resize(nTop - 1)
        End If
        If nBottom < MaxRow Then
            Set rExt(4) = ws.Rows(nTop + nRow).Resize(MaxRow - nBottom)
        End If
        If nLeft > 1 Then
            Set rExt(2) = ws.Cells(nTop, 1).Resize(nRow, nLeft - 1)
        End If
        If nRight < MaxCol Then
            Set rExt(3) = ws.Cells(nTop, nLeft + nCol) _
                .Resize(nRow, MaxCol - nRight)
        End If

        Set rRev = Nothing
        For i = 1 To 4
            If Not rExt(i) Is Nothing Then
                If rRev Is Nothing Then
                    Set rRev = rExt(i)
                Else
                    Set rRev = Union(rRev, rExt(i))
                End If
            End If
        Next

        If rRev Is Nothing Then Exit Function
        Set rRev = Intersect(rRev, rSource)
        If rRev Is Nothing Then Exit Function
        If rRet Is Nothing Then
            Set rRet = rRev
        Else
            Set rRet = Intersect(rRet, rRev)
        End If
    Next
    Set Ununion = rRet
End Function


Function UnionMergeArea(ByVal rTarget As Range) As Range
    Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
    Dim r As Range
    Dim m As Long, n As Long, p As Long, q As Long
    Dim nRow As Long, nCol As Long
    Dim nLeft() As Long, nRight() As Long
    Dim nTop() As Long, nBottom() As Long
    Dim vTrue As Variant
    Dim ma As Collection
    Dim s As String

    If rTarget Is Nothing Then Exit Function
    Set r = rTarget.Cells(1).MergeArea
    Set ma = New Collection

    For Each r1 In rTarget.Areas
        nRow = r1.Rows.Count
        nCol = r1.Columns.Count
        n = Int(Log(nRow) / Log(2)) + 1
        ReDim nTop(1 To n)
        ReDim nBottom(1 To n)
        n = Int(Log(nCol) / Log(2)) + 1
        ReDim nLeft(1 To n)
        ReDim nRight(1 To n)

        p = 1
        nLeft(p) = 1
        nRight(p) = nCol
        Do While p > 0
            n = nRight(p) - nLeft(p) + 1
            Set r2 = r1.Columns(nLeft(p)).Resize(, n).Cells
            vTrue = r2.MergeCells
            If IsNull(vTrue) Then
                If n = 1 Then
                    q = 1
                    nTop(q) = 1
                    nBottom(q) = nRow
                    Do While q > 0
                        n = nBottom(q) - nTop(q) + 1
                        Set r3 = r2.Rows(nTop(q)).Resize(n).Cells
                        vTrue = r3.MergeCells
                        If IsNull(vTrue) Then
                            m = n \ 2
                            nTop(q + 1) = nTop(q)
                            nBottom(q + 1) = nTop(q) + m - 1
                            nTop(q) = nTop(q) + m
                            q = q + 1
                        Else
                            If vTrue Then
                                Set r3 = Ununion(r3, r)
                                Do Until r3 Is Nothing
                                    Set r4 = r3(1).MergeArea
                                    s = r4.Address
                                    On Error Resume Next
                                    ma.Add Nothing, s
                                    If Err = 0 Then Set r = Union(r, r4)
                                    On Error GoTo 0
                                    Set r3 = Ununion(r3, r)
                                Loop
                            Else
                                Set r = Union(r, r3)
                            End If
                            q = q - 1
                        End If
                    Loop
                    p = p - 1
                Else
                    m = n \ 2
                    nLeft(p + 1) = nLeft(p)
                    nRight(p + 1) = nLeft(p) + m - 1
                    nLeft(p) = nLeft(p) + m
                    p = p + 1
                End If
            Else
                If vTrue Then
                    Set r2 = Ununion(r2, r)
                    Do Until r2 Is Nothing
                        Set r4 = r2(1).MergeArea
                        s = r4.Address
                        On Error Resume Next
                        ma.Add Nothing, s
                        If Err = 0 Then Set r = Union(r, r4)
                        On Error GoTo 0
                        Set r2 = Ununion(r2, r)
                    Loop
                Else
                    Set r = Union(r, r2)
                End If
                p = p - 1
            End If
        Loop
    Next
    Set UnionMergeArea = r
End Function



Sub Unselect()
    Dim r As Range
    If TypeName(Selection) <> "Range" Then Exit Sub
    On Error Resume Next
    Set r = Application.InputBox( _
        prompt:="Select the range to exclude.", _
        Title:="Unselect", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub
    Set r = UnionMergeArea(r)
    Set r = Ununion(Selection, r)
    Set r = UnionMergeArea(r)
    If r Is Nothing Then
        MsgBox "No cell was left."
    Else
        r.Select
    End If
End Sub


Sub ExcludeSelection()
    Dim r As Range
    If TypeName(Selection) <> "Range" Then Exit Sub
    Do
        Set r = Nothing
        On Error Resume Next
        Set r = Application.InputBox( _
            prompt:="Select the source range.", _
            Title:="Exclude selection", Type:=8)
        On Error GoTo 0
        If r Is Nothing Then Exit Sub
        If Not ((r.Worksheet.Name <> ActiveSheet.Name) Or _
                (r.Worksheet.Parent.Name <> ActiveWorkbook.Name)) Then
            Exit Do
        End If
    Loop
    Set r = UnionMergeArea(r)
    Set r = Ununion(r, Selection)
    Set r = UnionMergeArea(r)
    If r Is Nothing Then
        MsgBox "No cell was left."
    Else
        r.Select
    End If
End Sub