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

[Lu76Fer]

💾 : DetectArea.xlsm

Bonjour à tous,

Je vais commencer par donner la solution la plus évidente puis une version optimisée avec quelques contraintes. Ensuite, j'espère avoir d'autres idées originales de votre part.​

On initialise d'abord les zones sur lesquelles on travaille en nommant un Range : [Serie] avec un ensemble de zones (areas). Puis définissons £cel, la cellule à partir de laquelle on va lister les zones présentent.​

Les algorithmes
Solution 1 dans le module de la feuille "Algos" avec l'utilisation d'une boucle sur chaque zone pour laquelle on fait l'intersection entre la cellule et la zone :

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

​

Pour optimiser cet algorithme il est possible d'éviter la boucle dans Detect1 en stockant sous forme de tableau la présence de chaque zone selon la ligne et selon la colonne. Un tableau à 2 dimensions comportant tous les résultats déjà calculés serait efficace mais trop volumineux et long à initialiser ! Il est plus raisonnable de créer 2 tableaux : 1 pour les lignes et 1 pour les colonnes puis de combiner les données. Exemple : si la zone 2 est présente en ligne 5 et en colonne 3 alors elle est présente au niveau de la cellule (5,3).​

Avant de créer ces 2 tableaux, il sera intéressant de connaitre toutes les caractéristiques du range contenant les zones à gérer. Le range est composé de zone rectangulaire avec (Ligne min, ligne max, colonne min, colonne max) et l'ensemble de ces rectangles peuvent être contenus par le plus petit "rectangle" possible les contenants tous.​

Notre fonction retournera sous forme de collection l'ensemble des "rectangles" composant le Range et par référence chacune des caractéristiques du "rectangle" les englobant tous (module Tools) :

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

​

Il est plus facile d'écrire la fonction permettant de générer les tableaux de présence de zone car on pourra minimiser la dimension des tableaux. On les passera par référence car ils seront spécifiques à la feuille sur laquelle on les utilise.​

Pour stocker les informations concernant les zones présentent j'utilise un entier et chaque bit de cet entier me permet de connaitre si sa zone associée est présente (=1). Le 1er bit sera associé à la zone 1 le 2ème à la 2 ... Un entier étant composé de 2 octets on peut stocker théoriquement l'information sur 16 zones, cependant la manipulation des bits n'est pas pratique en Basic et il faut passer par les maths. Pour simplifier on exploitera que les nombres positifs et on utilisera donc pas le bit le plus à gauche qui reste à 0, ce qui nous limite à 15 zones gérées. Pour balayer chaque bit de droite à gauche, il suffit de partir de mskArea = 1 puis de faire mskArea = mskArea x 2 pour se déplacer sur le bit à gauche et mskArea = mskArea / 2 pour se déplacer sur le bit à droite. Pour combiner notre bit avec la valeur du tableau : t(i) = t(i) Or mskArea. Une fonction logique est combiné bit à bit entre les 2 variables.​

Il suffit enfin de balayer pour chaque tableau (lignes et colonnes) entre le min et le max toutes les caractéristiques de chaque zone, déterminer si la zone est présente et si oui l'ajouter au tableau (module Tools) :

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

Pour connaitre les zones présentent à la position de la cellule £cel il suffit d'utiliser l'opérateur And entre les tableaux des lignes et des colonnes (placé dans le module de feuille pour simplifier) :

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

Ensuite, on a besoin de pouvoir lire le résultat retourné sur un entier bit à bit et la technique est la même que pour l'écriture mais en utilisant l'opérateur logique And. la fonction renvoie dans un tableau la liste des positions à 1 dans l'ordre croissant (module Tools) :

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

Solution 2 dans le module de feuille "Algo" :

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

Remarque : il est possible de décaler les bits avec les fonctions utilisateurs Bitrshift(val, 1) et Bitlshift(val, 1).
❓ Est-ce qu'il s'agit d'un véritable décalage de bit comme pour une commande assembleur et pourquoi utiliser le type Double ?

Test de performance

​

Il s'agit de l'onglet "Benchmark", ici il est possible de tester l'algorithme développé ci-dessus et de lancer les tests pour comparer les performances entre Algo 1 optimisé et Algo 2 la version classique.​

On peut remarquer d'après les résultats que la méthode Intersect est très efficace par rapport à la version que j'ai optimisée. Evidemment, pour identifier la zone avec la méthode Intersect il faut répéter pour chaque zone, le temps est multiplié par le nombre de zone. Toutefois, le temps de traitement pour chaque opération reste faible et pour 15 zones le temps nécessaire est inférieur à 50 µS !​

 

[patricktoulon]

re
bonjour @Lu76Fer
rien compris à tout ce ramdam
pour le coup quoi ;tu cherche dans quelle area d'une plage non contiguë est une cellule ?
c'est ça ?
je pige pas trop l'intention
je te donne la ligne et colonne par rapport à l'area (et non la plage )

Sub test()
    Set cel = [d5]
    leszones = Split([serie].Address, ",")
    For i = 0 To UBound(leszones)
        Set r = Range(leszones(i))
        If Not Intersect(cel, r) Is Nothing Then
            Debug.Print "[D5] :" & _
                         " Zone :" & r.Cells(1) & " : [" & r.Address & _
                         "] ligne :" & cel.Row - r.Row + 1 & _
                         "  Colonne : " & cel.Column - r.Column + 1
        End If
    Next
End Sub

debug

[D5] : Zone :1 : [$B$2:$D$6] ligne :4 Colonne : 3
[D5] : Zone :2 : [$C$5:$E$9] ligne :1 Colonne : 2
[D5] : Zone :3 : [$D$3:$F$5] ligne :3 Colonne : 1

j'ai mis l'identifiant(1,2,3) en cells (1) de chaque area

 

[Lu76Fer]

re
bonjour @Lu76Fer
rien compris à tout ce ramdam
pour le coup quoi ;tu cherche dans quelle area d'une plage non contiguë est une cellule ?
c'est ça ?
je pige pas trop l'intention

Bonjour @patricktoulon,
Je pensais que c'était compréhensible mais j'avais besoin de pouvoir identifier sur quelle(s) zone(s) une cellule donnée est situé avec un algo performant. La façon la plus simple de faire cela étant une boucle sur chaque zone et en vérifiant l'Intersection entre la cellule et la zone.
De mon côté j'ai développé un code pour avoir des résultats pré-calculés afin d'optimiser le temps de calcul. Cela fonctionne mais après coup je me suis rendu compte que la méthode Intersect est très efficace (temps d'exécution de quelques µS) et finalement le jeu n'en vaut pas la chandelle.
Ma question c'est simplement de savoir si il y avait une autre façon originale de procédé ? Bien-sûr ce n'est pas du tout bloquant, c'est juste une question ouverte.
Merci, pour l'attention apportée !