Difference of two Ranges

Vishesh's picture

This function gives the difference of two ranges (output is range). It is opposite of union of ranges. Its NOT intersection either.
Copy the following code in a general module and call the TestRun function with required ranges to see how it works.



Sub TestRun()
    Dim rngDiff As Range
    Set rngDiff = DeltaRange(Sheet1.Range("A1:E20"), Sheet1.Range("B5:D15"))
    If Not rngDiff Is Nothing Then
        rngDiff.Interior.Color = 9944773
    End If
    Set rngDiff = Nothing
End Sub
Public Function DeltaRange(ByVal rng1 As Range, ByVal rng2 As Range) As Range
    Dim rngSmall        As Range
    Dim rngBig          As Range
    Dim rngIntersect    As Range
    Dim rngTopRows      As Range
    Dim rngBtmRows      As Range
    Dim rngLeftCols     As Range
    Dim rngRightCols    As Range
    Dim rngUnion        As Range
    Dim strMsg          As String
    If rng1.Areas.Count > 1 Or rng2.Areas.Count > 1 Then
        strMsg = "Both the ranges should be rectangular."
        GoTo ErrH
    ElseIf rng1.Address = rng2.Address Then
        strMsg = "Both ranges are equal."
        GoTo ErrH
        If getCellCount(rng1) < getCellCount(rng2) Then
            Set rngSmall = rng1
            Set rngBig = rng2
            Set rngSmall = rng2
            Set rngBig = rng1
        End If
    End If
    On Error Resume Next
    Set rngIntersect = Intersect(rngSmall, rngBig)
    On Error GoTo 0
    If rngIntersect Is Nothing Then
        strMsg = "No common area in two ranges"
        GoTo ErrH
        If rngIntersect.Address <> rngSmall.Address Then
            Set rngSmall = rngIntersect
        End If
    'Top Rows

        If rngBig.Rows(1).Row <> rngSmall.Rows(1).Row Then
            Set rngTopRows = rngBig.Rows(1).Resize(rngSmall.Rows(1).Row - rngBig.Rows(1).Row)
            Call AppendToRange(rngUnion, rngTopRows)
        End If
    'Bottom Rows

        If rngBig.Rows(rngBig.Rows.Count).Row <> rngSmall.Rows(rngSmall.Rows.Count).Row Then
            Set rngBtmRows = rngBig.Rows(rngSmall.Rows(rngSmall.Rows.Count).Row -  _
               rngBig.Rows(1).Row + 2).Resize(rngBig.Rows(rngBig.Rows.Count).Row -  _
            Call AppendToRange(rngUnion, rngBtmRows)
        End If
    'Left Colums

        If rngBig.Columns(1).Column <> rngSmall.Columns(1).Column Then
            Set rngLeftCols = rngBig.Columns(1). _
                Resize(, rngSmall.Columns(1).Column - rngBig.Columns(1).Column)
            Call AppendToRange(rngUnion, rngLeftCols)
        End If
    'Right Columns

        If rngBig.Columns(rngBig.Columns.Count).Column <> rngSmall.Columns(rngSmall.Columns.Count).Column Then
            Set rngRightCols = rngBig.Columns(rngSmall.Columns(rngSmall.Columns.Count).Column -  _
              rngBig.Columns(1).Column + 2).Resize(, rngBig.Columns(rngBig.Columns.Count).Column  _
              - rngSmall.Columns(rngSmall.Columns.Count).Column)
            Call AppendToRange(rngUnion, rngRightCols)
        End If
    End If
    Set DeltaRange = rngUnion
    GoTo ExitH
    MsgBox strMsg, vbInformation, ".::Error::."
    Set DeltaRange = Nothing
    Set rngSmall = Nothing
    Set rngBig = Nothing
    Set rngIntersect = Nothing
    Set rngTopRows = Nothing
    Set rngBtmRows = Nothing
    Set rngLeftCols = Nothing
    Set rngRightCols = Nothing
    Set rngUnion = Nothing
End Function
Private Function getCellCount(rng As Range) As Double
    Dim dblRowCount     As Double
    Dim dblColCount     As Double
    dblRowCount = rng.Rows.Count
    dblColCount = rng.Columns.Count
    getCellCount = dblRowCount * dblColCount
    dblRowCount = Empty
    dblColCount = Empty
End Function
Private Sub AppendToRange(rngAppendTo As Range, rngAppend As Range)
    If Not rngAppendTo Is Nothing Then
        Set rngAppendTo = Union(rngAppendTo, rngAppend)
        Set rngAppendTo = rngAppend
    End If
End Sub



Difference of Ranges

DifferenceOfRanges.xls35 KB