XL 2016 XLS - Comment déterminer les zones présentent au niveau d'une cellule ?

Sub Detect1(£cel As Range)
Dim £rects As Range, £rect As Range, cnt%
   Set £rects = [Serie]
   For Each £rect In £rects.Areas
      cnt = cnt + 1
      If Not (Intersect(£cel, £rect) Is Nothing) Then Debug.Print "   Zone n° " & cnt
   Next £rect
End Sub

Sub Test1()
   Debug.Print "[D5] : ": Detect1 [D5]
   Debug.Print "[C12] : ": Detect1 [C12]
   Debug.Print "[C6] : ": Detect1 [C6]
End Sub

Function SpecAreas(ByRef rowMin%, ByRef rowMax%, ByRef colMin%, ByRef colMax%, £areas As Range) As Collection
Dim £area As Range, iRowMax As Integer, iColMax As Integer
   rowMin = £areas.Areas(1).Row: colMin = £areas.Areas(1).Column: Set SpecAreas = New Collection
   For Each £area In £areas.Areas
      If £area.Row < rowMin Then rowMin = £area.Row
      iRowMax = £area.Row + £area.Rows.Count - 1
      If iRowMax > rowMax Then rowMax = iRowMax
      If £area.Column < colMin Then colMin = £area.Column
      iColMax = £area.Column + £area.Columns.Count - 1
      If iColMax > colMax Then colMax = iColMax
      SpecAreas.Add Array(£area.Row, iRowMax, £area.Column, iColMax)
   Next £area
End Function

Sub RecordPosAreas(£areas As Range, pRowAreas() As Integer, pColAreas() As Integer)
Dim cl As Collection, rowMin%, rowMax%, colMin%, colMax%, v As Variant, cnt%, mskArea%
   Set cl = SpecAreas(rowMin, rowMax, colMin, colMax, £areas)
   ReDim pRowAreas(rowMin To rowMax): ReDim pColAreas(colMin To colMax)
   For cnt = rowMin To rowMax
      mskArea = 1
      For Each v In cl
         If cnt >= v(0) And cnt <= v(1) Then pRowAreas(cnt) = pRowAreas(cnt) Or mskArea
         If mskArea < 16000 Then mskArea = mskArea * 2   'Limited to 15 areas
      Next v
   Next cnt
   For cnt = colMin To colMax
      mskArea = 1
      For Each v In cl
         If cnt >= v(2) And cnt <= v(3) Then pColAreas(cnt) = pColAreas(cnt) Or mskArea
         If mskArea < 16000 Then mskArea = mskArea * 2   'Limited to 15 areas
      Next v
   Next cnt
End Sub

Function RectsOnCell(£cel As Range) As Integer
   If £cel.Row < LBound(RowRects) Or £cel.Row > UBound(RowRects) Then Exit Function
   If £cel.Column < LBound(ColRects) Or £cel.Column > UBound(ColRects) Then Exit Function
   RectsOnCell = RowRects(£cel.Row) And ColRects(£cel.Column)
End Function

Function GetBitPosEq1(val As Integer) As Variant
Dim nb%, pos%, mskArea%, vals() As Variant
   If val <= 0 Then Exit Function
   mskArea = 1: ReDim vals(14)   '15 max
   Do Until val < mskArea
      nb = nb + 1: If val And mskArea Then vals(pos) = nb: pos = pos + 1
      If mskArea > 16000 Then Exit Do
      mskArea = mskArea * 2   '#Shift to left
   Loop
   ReDim Preserve vals(pos - 1): GetBitPosEq1 = vals
End Function

Sub Detect2(£cel As Range)
Dim val%
   val = RectsOnCell(£cel) 'Get the set of rectangles on the position of cel
   'Extract bit position on val and display the list of rectangles
   If val > 0 Then Debug.Print "   Zone(s) n°" & Join(GetBitPosEq1(val), ",")
End Sub

Sub Test2()
   RecordPosAreas [Serie], RowRects, ColRects  'Init
   Debug.Print "[D5] : ": Detect2 [D5]
   Debug.Print "[C12] : ": Detect2 [C12]
   Debug.Print "[C6] : ": Detect2 [C6]
End Sub