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
