Option Explicit

Public Function RangeFind(ToMatch As Range, SearchIn As Range, Optional Instance As Integer = 0) As String

Dim rngToMatch As Range
Dim rngSearchIn As Range
Dim intInstance As Integer

Dim arrvResults As Variant
Dim booSuccess As Boolean

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = True

    ' Set up the ToMatch range
    Set rngToMatch = ToMatch

    ' Set up the SearchIn range
    Set rngSearchIn = SearchIn

    ' Set up the instance counter and take 0 (the first range found) by default
    intInstance = Instance

    ' Call the custom routine below built to give the array of all matches
    booSuccess = arrRangeFind(rngToMatch, rngSearchIn, arrvResults)

    ' If no success then quit out
    If Not booSuccess Then
        RangeFind = "No Matches"
        Exit Function
    End If

    ' If instance count too high give message else give address of match
    If intInstance > UBound(arrvResults) Then
        RangeFind = "Not enough range matches"
    Else
        RangeFind = arrvResults(intInstance).Address
    End If

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = False

End Function

Private Function arrRangeFind(ByVal rngToMatch As Range, ByVal rngSearchIn As Range, ByRef vAllRanges As Variant) As Boolean

Dim Cell As Range
Dim SearchCells As Range
Dim MatchRange As Range

Dim arrFound() As Range
Dim intFoundCounter As Integer
Dim i As Integer

    ' Search every cell in the search range
    For Each Cell In rngSearchIn

        ' Create a subset of cells in the search range that match the TLH cell value
        If Cell.Value = rngToMatch.Cells(1, 1).Value Then

            If SearchCells Is Nothing Then
                Set SearchCells = Cell
            Else
                Set SearchCells = Union(SearchCells, Cell)
            End If

        End If

    Next

    intFoundCounter = 0

    ' Now search through our list of initially matching cells
    For Each Cell In SearchCells

        Set MatchRange = Range(Cell, Cell.Offset(rngToMatch.Rows.Count - 1, rngToMatch.Columns.Count - 1))

        ' use our custom RangesMtach function to determine if the pair of ranges do match
        If RangesMatch(rngToMatch, MatchRange) Then

            ' Resize the array of found ranges
            ReDim Preserve arrFound(intFoundCounter)

            ' Add our newly found range
            Set arrFound(intFoundCounter) = MatchRange

            ' Move the found counter on one
            intFoundCounter = intFoundCounter + 1

        End If

    Next Cell

    ' Set up the output
    If intFoundCounter = 0 Then
        Set vAllRanges = Nothing
        arrRangeFind = False
    Else
        vAllRanges = arrFound
        arrRangeFind = True
    End If

End Function

Private Function RangesMatch(ByRef rng1 As Range, ByRef rng2 As Range) As Boolean

Dim i As Integer
Dim j As Integer

    ' Check they are not the same range
    If rng1.Parent.Name = rng2.Parent.Name And rng1.Address = rng2.Address Then
        RangesMatch = False
        Exit Function
    End If

    ' Check the two ranges have the same number of columns
    If rng1.Columns.Count <> rng2.Columns.Count Then
        RangesMatch = False
        Exit Function
    End If

    ' Check the two ranges have the same number of rows
    If rng1.Rows.Count <> rng2.Rows.Count Then
        RangesMatch = False
        Exit Function
    End If

    ' Match the values in ecah corresponding cell and quit out if different
    For i = 1 To rng1.Rows.Count
        For j = 1 To rng1.Columns.Count
            If rng1.Cells(i, j).Value <> rng2.Cells(i, j).Value Then
                RangesMatch = False
                Exit Function
            End If
        Next j
    Next i

    ' If we've got here then we must have a match
    RangesMatch = True

End Function