Monday, April 13, 2020

Subtracting one range from another in VBA

Option Explicit
Private mrBuild As Range
Sub selection_experiment()
Sheets("RCformula").Select

Dim workingrange As Range


Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Set workingrange = Selection
MsgBox (workingrange.Address)
Dim removefromrange As Range
Range("A1").Select
Selection.End(xlDown).Select
Set removefromrange = Selection
MsgBox (removefromrange.Address)
MsgBox (SubtractRanges(workingrange, removefromrange).Address)


End Sub



Public Function SubtractRanges(rFirst As Range, rSecond As Range) As Range

    Dim rInter As Range
    Dim rReturn As Range
    Dim rArea As Range

    Set rInter = Intersect(rFirst, rSecond)
    Set mrBuild = Nothing

    If rInter Is Nothing Then 'No overlap
        Set rReturn = rFirst
    ElseIf rInter.Address = rFirst.Address Then 'total overlap
        Set rReturn = Nothing
    Else 'partial overlap
        For Each rArea In rFirst.Areas
            BuildRange rArea, rInter
        Next rArea
        Set rReturn = mrBuild
    End If

    Set SubtractRanges = rReturn

End Function

Sub BuildRange(rArea As Range, rInter As Range)

    Dim rLeft As Range, rRight As Range
    Dim rTop As Range, rBottom As Range

    If Intersect(rArea, rInter) Is Nothing Then 'no overlap
        If mrBuild Is Nothing Then
            Set mrBuild = rArea
        Else
            Set mrBuild = Union(mrBuild, rArea)
        End If
    Else 'some overlap
        If rArea.Columns.count = 1 Then 'we've exhausted columns, so split on rows
            If rArea.Rows.count > 1 Then 'if one cell left, don't do anything
                Set rTop = rArea.Resize(rArea.Rows.count \ 2) 'split the range top to bottom
                Set rBottom = rArea.Resize(rArea.Rows.count - rTop.Rows.count).Offset(rTop.Rows.count)
                BuildRange rTop, rInter 'rerun it
                BuildRange rBottom, rInter
            End If
        Else
            Set rLeft = rArea.Resize(, rArea.Columns.count \ 2) 'split the range left to right
            Set rRight = rArea.Resize(, rArea.Columns.count - rLeft.Columns.count).Offset(, rLeft.Columns.count)
            BuildRange rLeft, rInter 'rerun it
            BuildRange rRight, rInter
        End If
    End If

End Sub


Source:https://stackoverflow.com/questions/21580795/subtracting-ranges-in-vba-excel

No comments:

Post a Comment