SubtractRanges.bas

'
'
' SUBTRACTING RANGES. PART 1. INTERACTIVE MACROS
'
'



Public Sub ExcludeFromSelection()
'
' De-select a user-defined range
'
    If ActiveSheet Is Nothing Then Exit Sub

    Application.StatusBar = "Please wait..."
    
    Dim rInitial As Range
    Dim rExclude As Range
    Set rInitial = Selection
    
    On Error Resume Next 'in case user hits 'Cancel'
    Set rExclude = Application.InputBox("Select a range to exclude from selection", , , , , , , 8)
    On Error GoTo 0
    
    iCursor = Application.Cursor
    Application.Cursor = xlWait
    
    Dim rNewSelection As Range
    If Not rExclude Is Nothing And Not rInitial Is Nothing Then
        Set rNewSelection = SubtractRanges(rInitial, rExclude)
    End If
    
    Call SanitizedSelect(rNewSelection)
    
    Application.StatusBar = False
    Application.Cursor = iCursor
End Sub



Public Sub InvertSelection()
'
' Inverts selection
'
    If ActiveSheet Is Nothing Then Exit Sub

    Application.StatusBar = "Please wait..."
    iCursor = Application.Cursor
    Application.Cursor = xlWait
    
    Dim rOldSelection As Range
    Dim rNewSelection As Range
    Dim wsCurrent As Worksheet
    
    Set rOldSelection = Selection
    Set wsCurrent = ActiveSheet
    
    Dim rIntersection As Range
    Set rIntersection = Intersect(wsCurrent.UsedRange, rOldSelection)
    
    ' Simplify the calculations if the selection is inside the UsedRange
    Dim OnlyUsedRange As Boolean
    OnlyUsedRange = False
    If Not rIntersection Is Nothing Then
        If rIntersection.Address = rOldSelection.Address Then
            OnlyUsedRange = True
        End If
    End If
    Set rIntersection = Nothing
    
    If OnlyUsedRange Then
        Dim rPartA As Range
        Dim rPartB As Range
        Set rPartA = SubtractRanges(wsCurrent.Cells, wsCurrent.UsedRange)
        Set rPartB = SubtractRanges(wsCurrent.UsedRange, rOldSelection)
        Set rNewSelection = AddRanges(rPartA, rPartB)
        Set rPartA = Nothing
        Set rPartB = Nothing
    Else
        Set rNewSelection = SubtractRanges(wsCurrent.Cells, rOldSelection)
    End If
    
    Call SanitizedSelect(rNewSelection)

    Application.StatusBar = False
    Application.Cursor = iCursor
End Sub



'
'
' SUBTRACTING RANGES. PART 2. BEHIND-THE-SCENE FUNCTIONS
'
'



Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range
'
' Returns a range of cells that are part of rFirst, but not part of rSecond
' (as in set subtraction)
'
' This function handles big input ranges really well!
'
' Separate recursive function is used to
' hide third parameter of the recursive function.
'
    Set SubtractRanges = BuildRange(rFirst, rSecond)
End Function



Private Function BuildRange(rArea As Range, rInter As Range, _
Optional mrBuild As Range = Nothing) As Range
'
' Recursive function for SubtractRanges()
'
' Subtracts rInter from rArea and adds the result to mrBuild
'
    Dim rHalf As Range
    Dim rOtherHalf As Range
    Dim rChunk As Range
    Dim rInterSub As Range
    Dim GoByColumns As Boolean
    Dim rSubArea As Range

    If Not rArea Is Nothing Then
        If Not rInter Is Nothing Then
            Set rInterSub = Intersect(rArea, rInter)
        Else
            Set rInterSub = rInter
        End If
        If rInterSub Is Nothing Then 'no overlap
            If mrBuild Is Nothing Then
                Set mrBuild = rArea
            Else
                Set mrBuild = Union(mrBuild, rArea)
            End If
        ElseIf Not (rInterSub.Address(False, False) = rArea.Address(False, False) _
                    And rArea.Areas.Count = 1) Then 'some overlap
            For Each rSubArea In rArea.Areas
                If Not rSubArea.Cells.CountLarge = 1 Then 'just in case there is only one cell for some impossible reason
                    ' Decide whether to go by columns or by rows
                    ' (helps when subtracting whole rows/columns)
                    If Not rInterSub.Columns.Count = rSubArea.Columns.Count And _
                    ((Not rInterSub.Cells.CountLarge = 1 And _
                    (rInterSub.Rows.Count > rInterSub.Columns.Count _
                    And rSubArea.Columns.Count > 1) Or (rInterSub.Rows.Count = 1 _
                    And Not rSubArea.Columns.Count = 1)) Or _
                    (rInterSub.Cells.CountLarge = 1 _
                    And rSubArea.Columns.Count > rSubArea.Rows.Count)) Then
                            GoByColumns = True
                    Else
                            GoByColumns = False
                    End If
                    
                    Halfs = SplitRangeInHalf(rSubArea, GoByColumns)
                    Set rHalf = Halfs(1)
                    Set rOtherHalf = Halfs(2)
                    
                    Set mrBuild = BuildRange(rHalf, rInterSub, mrBuild) 'rerun it
                    Set mrBuild = BuildRange(rOtherHalf, rInterSub, mrBuild)
                    
                    'Debug
                    If False Then
                        Debug.Print "By columns: " & GoByColumns
                        Debug.Print "Area: " & rSubArea.Address(False, False)
                        Debug.Print "rInter: " & rInter.Address(False, False)
                        If Not rHalf Is Nothing Then Debug.Print "rHalf: " & rHalf.Address(False, False)
                        If Not rOtherHalf Is Nothing Then Debug.Print "rOtherHalf: " & rOtherHalf.Address(False, False)
                        If Not mrBuild Is Nothing Then Debug.Print "Result: " & mrBuild.Address(False, False)
                        Debug.Print ""
                    End If
                End If
            Next rSubArea
        End If
    End If 'Not rArea Is Nothing

    Set BuildRange = mrBuild
End Function



Public Function SplitRangeInHalf(rArea As Range, _
Optional GoByColumns As Boolean = True) As Variant
'
' Split rArea into two ranges more or less of the same size
' vertically (GoByColumns = True) or horizontally (GoByColumns = False)
'
' rArea has to be a single *contiguous* range
'
' Returns an array (1 To 2) containing two ranges
'
    Dim Halfs(1 To 2) As Range
    Dim rReserved As Range
    
    Dim wsCurrent As Worksheet
    Set wsCurrent = GetWorksheet(rArea)
    
    If Not rArea Is Nothing Then
        If rArea.Areas.Count <> 1 Then Err.Raise 1004, , "Input range has to be contiguous"
        
        Dim bMergedCell As Boolean
        If IsNull(rArea.MergeCells) Then
            bMergedCell = False
        Else
            Dim tmp1 As Range
            Set tmp1 = Intersect(rArea, rArea.Cells(1, 1).MergeArea)
            If Not tmp1 Is Nothing Then
                bMergedCell = rArea.MergeCells And _
                 (tmp1.Address(False, False) = rArea.Address(False, False))
            Else
                bMergedCell = False
            End If 'Not tmp1 Is Nothing
        End If 'IsNull(rArea.MergeCells)
        
        If Not (rArea.CountLarge = 1 Or bMergedCell) Then
            If rArea.Rows.Count = 1 Then GoByColumns = True 'corner cases override
            If rArea.Columns.Count = 1 Then GoByColumns = False
            
            If Not GoByColumns Then
                Set Halfs(1) = rArea.Resize(rArea.Rows.Count \ 2) 'split the range top to bottom
                
                Set rReserved = wsCurrent.Range( _
                    wsCurrent.Cells.Rows(wsCurrent.Cells.Rows.Count - rArea.Rows.Count + 1), _
                    wsCurrent.Cells.Rows(wsCurrent.Cells.Rows.Count _
                    )) 'make sure we can do offset.resize
                
                If Intersect(rReserved, Halfs(1)) Is Nothing Then
                    Set Halfs(2) = rArea.Offset(Halfs(1).Rows.Count).Resize(rArea.Rows.Count - Halfs(1).Rows.Count) 'best method, but it doesn't work if we run out of cells on the worksheet
                ElseIf Halfs(1).Cells(1, 1).MergeArea.Address = Halfs(1).Address And _
                Not Halfs(1).Cells(1, 1).Address = Halfs(1).Address Then 'workaround for the workaround drawback for the bug below :)
                    For Each rChunk In rArea.Rows
                        If Intersect(rChunk, Halfs(1)) Is Nothing Then
                            Set Halfs(2) = AddRanges(Halfs(2), rChunk)
                        End If
                    Next rChunk
                Else
                    Set Halfs(2) = rArea.Resize(rArea.Rows.Count - Halfs(1).Rows.Count).Offset(Halfs(1).Rows.Count) 'buggy! workaround above
                End If
            Else
                Set Halfs(1) = rArea.Resize(, rArea.Columns.Count \ 2) 'split the range left to right
                
                Set rReserved = wsCurrent.Range( _
                    wsCurrent.Cells.Columns(wsCurrent.Cells.Columns.Count - rArea.Columns.Count + 1), _
                    wsCurrent.Cells.Columns(wsCurrent.Cells.Columns.Count _
                    ))
                    
                If Intersect(rReserved, Halfs(1)) Is Nothing Then
                    Set Halfs(2) = rArea.Offset(, Halfs(1).Columns.Count).Resize(, rArea.Columns.Count - Halfs(1).Columns.Count)
                ElseIf Halfs(1).Cells(1, 1).MergeArea.Address = Halfs(1).Address And _
                Not Halfs(1).Cells(1, 1).Address = Halfs(1).Address Then 'workaround for the workaround drawback for the bug below :)
                    For Each rChunk In rArea.Columns
                        If Intersect(rChunk, Halfs(1)) Is Nothing Then
                            Set Halfs(2) = AddRanges(Halfs(2), rChunk)
                        End If
                    Next rChunk
                Else
                    Set Halfs(2) = rArea.Resize(, rArea.Columns.Count - Halfs(1).Columns.Count).Offset(, Halfs(1).Columns.Count) 'buggy! workaround above
                End If
                'BUG DESCRIPTION
                '   If Halfs(1) is one merged cell, resize.offset will return one column
                '   no matter how many rows there were really
                'STEPS TO REPRODUCE
                '   - Create new sheet
                '   - Merge cells A1:A7
                '   - Debug.Print Range("A1:B7").Resize(,1).Offset(,1).Address
                '     will return "$B$1" instead of "$B$1:$B$7"
                'WORKAROUND
                '   If the range in question is less than 2/3 of worksheet wide
                '   offset.resize will work fine
                'DRAWBACK
                '   Offset.resize will work only if the whole range with offset
                '   fits in the worksheet
            End If
        Else 'corner case: single cell
            Set Halfs(1) = rArea
            Set Halfs(2) = Nothing
        End If
    End If
    
    SplitRangeInHalf = Halfs
End Function



'
'
' SUBTRACTING RANGES. PART 3. TESTS
'
'



Public Function RandomSubRange(rInit As Range) As Range
' Returns a random subrange of the given range
    Dim Chances(1 To 4) As Double
    Dim LuckyNumber As Double
    Dim tmpRange As Range

    Chances(1) = 0.25 'cell
    Chances(2) = 0.0095 'row
    Chances(3) = 0.0095 'column
    Chances(4) = 0.001 'whole range
    
    For Each Cell In rInit
        Randomize
        LuckyNumber = Rnd
        Select Case LuckyNumber
        Case 0 To Chances(1) 'cell
            Set tmpRange = AddRanges(tmpRange, Cell)
        Case Chances(1) To Chances(1) + Chances(2) 'row
            Set tmpRange = AddRanges(tmpRange, Cell.EntireRow)
        Case Chances(1) + Chances(2) To Chances(1) + Chances(2) + Chances(3) 'column
            Set tmpRange = AddRanges(tmpRange, Cell.EntireColumn)
        Case Chances(1) + Chances(2) + Chances(3) To Chances(1) + Chances(2) + Chances(3) + Chances(4) 'whole
            Set tmpRange = AddRanges(tmpRange, rInit)
        End Select
    Next Cell
    
    Set RandomSubRange = Intersect(rInit, tmpRange)
End Function



Private Function TestSubtractRanges(rInit As Range) As Boolean
' Test function for SubtractRanges. Returns True on success, False on error
    Dim Result As Boolean
    Result = True
    
    Dim rSecond As Range
    Set rSecond = RandomSubRange(rInit)
    
    Dim rSubtracted As Range
    Set rSubtracted = SubtractRanges(rInit, rSecond)
    
    ' 1. Intersection test
    If Not rSecond Is Nothing And Not rSubtracted Is Nothing Then
        If Not Intersect(rSubtracted, rSecond) Is Nothing Then
            Debug.Print "Intersection test failed for SubtractRanges(" & rInit.Address(False, False) & ", " & rSecond.Address(False, False) & ")"
            Result = False
        End If
    End If
    
    ' 2. Addition test
    If (Not SubtractRanges(AddRanges(rSubtracted, rSecond), rInit) Is Nothing) _
    Or (Not SubtractRanges(AddRanges(rSecond, rSubtracted), rInit) Is Nothing) Then
        Debug.Print "Addition test failed for SubtractRanges(" & rInit.Address(False, False) & ", " & rSecond.Address(False, False) & ")"
        Result = False
    End If
    
    TestSubtractRanges = Result
End Function



Private Sub RunTests(NumberOfTests As Integer, InitArea As Range)
' Run multiple tests
    Debug.Print "Running tests on " & InitArea.Address(False, False)
    FailedTests = 0
    For i = 1 To NumberOfTests
        If Not TestSubtractRanges(InitArea) Then FailedTests = FailedTests + 1
    Next i
    Debug.Print FailedTests & "/" & NumberOfTests & " tests failed"
End Sub


Public Sub Test()
'Test entrypoint
    Call RunTests(10, ActiveSheet.UsedRange)
End Sub


'
'
' SUBTRACTING RANGES. PART 4. HELPERS
'
'



Public Function AddRanges(RangeA, RangeB)
'
' The same as Union built-in but handles empty ranges fine.
'
    If Not RangeA Is Nothing And Not RangeB Is Nothing Then
        Set AddRanges = Union(RangeA, RangeB)
    ElseIf RangeA Is Nothing And RangeB Is Nothing Then
        Set AddRanges = Nothing
    Else
        If RangeA Is Nothing Then
            Set AddRanges = RangeB
        Else
            Set AddRanges = RangeA
        End If
    End If
End Function



Public Function GetWorksheet(aRange As Range) As Worksheet
'
' returns the worksheet a given range is located on
'
    Dim ws As Worksheet
    If Not aRange Is Nothing Then
        While ws Is Nothing
            If TypeOf aRange.Parent Is Worksheet Then
                Set ws = aRange.Parent
            Else
                Set aRange = aRange.Parent
            End If
        Wend
    End If
    Set GetWorksheet = ws
End Function