Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Notation Simplifiée pour définir un tableau arborescent

Lu76Fer

XLDnaute Occasionnel
Préambule
En cherchant à simplifier la déclaration de tableau imbriqué, j'ai exploré certaines pistes qui s'avéreront infructueuses ...
Pour clarifier, voici un petit exemple de déclaration :
VB:
Dim treeAr As Variant,
treeAr = Array(4, 7, 5, Array(4, 6, 8), 7)
Et j'aurai souhaité le déclarer comme ceci :
treeAr = [4, 7, 5, [4, 6, 8], 7]
Mais les crochets sont utilisés pour contenir une fonction utilisateur en langage Universel (l'anglais). Il est possible de déclarer un tableau de Variant à 2 dimensions avec cette syntaxe ou de lancer une fonction de son classeur mais pas une routine :
VB:
treeAr = [A1:C2] 'ou
treeAr = [Toto] 'Si on a nommé une zone Toto dans le classeur actif
'*** Avec une fonction du classeur ***
Function nAjout(ParamArray n()) As Variant
Dim v As Variant
    For Each v In n
        nAjout = nAjout + v
    Next v
End Function
'(...)
Dim v As Integer
    v = [nAjout(8,6,9)]
    debug.print v
Les limites : on ne peut pas lancer une fonction 'microsoft' mais seulement une fonction utilisateur ou une fonction appartenant à son classeur.

Après réflexion, je me suis dit que je pourrais faire ma notation sous forme de chaîne puis au travers d'une routine, remplacer '[' par 'Array(' et ']' par ')' puis demander une exécution du code à la volée à l'aide de la fonction 'Eval' qui devait me faire cela mais cette fonction n'existe qu'en VB ou sous Access et je ne suis pas vraiment sûr de ce qu'il est possible de faire avec.
Il existe bien aussi une fonction 'Application.Evaluate' mais ce n'est qu'une syntaxe différente de la notation abrégée [...]
VB:
v = [nAjout(8,6,9)]
'peut aussi s'écrire :
v = Evaluate("nAjout(8,6,9)")

Ma Notation Simplifiée
A l'approche de Noël et étant frustré de ne pas avoir ma Notation Simplifiée tel le gamin qui se verrait refuser sa liste de jouets, j'ai décidé de créer la mienne ...
VB:
Dim treeAr As Variant,
treeAr = "[4, 7, -5, [pim, pam, poum], 7]": § treeAr
et treeAr devient :

Comme il s'agit d'une chaîne de caractère et que les espaces sont ignorés (supprimés) j'ai fait le choix de ne gérer que des chaînes(String) sans espace ni guillemet et des nombres entiers relatifs(Integer).
Le code pourrait facilement être modifié pour gérer des types différents ou mieux gérer les chaînes de caractère... En cas d'erreur de syntaxe la routine renvoie Null

J'ai choisi '§' comme nom pour ma routine appelant la fonction récursive afin de créer une notation concise. A noter que l'on peut aussi utiliser les symboles suivants : ù,µ,£
VB:
'Fonction appelante de "AbNotToTreeArray"
'   treeAr : (String) Notation abrégée AbNot="[{val}|{AbNot},{val}|{AbNot},(...)]"
'       ex : "[4, 7, 5,[4, 6,[titi,Gros-Minet], 8]]"    rem. : "..." implicite car treeAr est une chaine
'Renvoie : un tableau arborescent de valeur de type String(sans , ou espace) ou Integer (si numérique)
'   et Null en cas d'erreur syntaxique en entrée
Sub §(ByRef treeAr As Variant)
Dim size As Integer, sAbNot As String
    On Error GoTo badSyntax
    sAbNot = Replace(treeAr, " ", "")
    size = Len(sAbNot)
    If AbNotToTreeArray(treeAr, sAbNot, size, 2) <> (size + 1) Then GoTo badSyntax
    Exit Sub
badSyntax:
    treeAr = Null
End Sub

'Fonction récursive permettant de convertir une notation abrégée 'sAbNot' en tableau arborescent de données 'treeAr'
'   size : nombre de caractère à traiter dans 'sAbNot' à partir de 'pos' (initialisée par <Len(sAbNot)> au départ)
'   pos : 'position de lecture' dans 'sAbNot' (Attention, il faut 'passer' le 1er '[')
'Retour : nouvelle 'position de lecture' de 'sAbNot'
Private Function AbNotToTreeArray(ByRef treeAr As Variant, ByRef sAbNot As String, size As Integer, pos As Integer) As Integer
Dim i1 As Integer, v2 As Variant, isOpn As Boolean, newPos As Integer
Dim idx As Integer, elt As Variant, subAr As Variant
    ReDim treeAr(size - 3)
    Do
        i1 = InStr(pos, sAbNot, "[")
        v2 = InStr(pos, sAbNot, "]")
        If (i1 > 0) Xor (v2 > 0) Then   'v1=Min(i1,v2) sauf si =0
            If i1 > v2 Then isOpn = True Else i1 = v2
        Else
            If i1 < v2 Then isOpn = True Else i1 = v2
        End If
        If isOpn Then  '[ : donnée de type Sub-Array alors appel récursif
            newPos = AbNotToTreeArray(subAr, sAbNot, size - i1 + 1, i1 + 1) 'newPos : future position après le Sub-Array (subAr)
            i1 = i1 - 1
        End If
        If i1 > pos Then
            v2 = Split(Mid(sAbNot, pos, i1 - pos), ",")
            For Each elt In v2  'Type String par défaut
                If IsNumeric(elt) Then elt = CInt(elt)  'Si val Numérique, conversion en Integer
                treeAr(idx) = elt: idx = idx + 1
            Next elt
        End If
        If isOpn Then  '[
            treeAr(idx) = subAr: idx = idx + 1
            pos = newPos: isOpn = False
        Else
            ReDim Preserve treeAr(idx - 1)
            i1 = i1 + 1
            AbNotToTreeArray = IIf(Mid(sAbNot, i1, 1) = ",", i1 + 1, i1)
            Exit Function
        End If
    Loop Until False    'Sortie si Erreur ou i1=v2=0
End Function

Les évolutions possibles
  • Il est possible de faire une version gérant les espaces dans les chaînes en introduisant un traitement préalable dans la routine '§'. Les chaînes pourraient être mise entre simple quote afin de faire la différence entre les espaces superflus et les espaces d'une chaîne.
  • Il est aussi possible de prendre en charge les nombres réels et les dates en modifiant la fonction récursive et en utilisant isDate, CDate ...
 
Dernière édition:

Lu76Fer

XLDnaute Occasionnel
Correctif :
Après avoir partagée ma notation simplifiée d'un tableau arborescent, j'ai continué à faire des tests et je me suis aperçu que j'avais sous-dimensionné ma variable treeAr et j'ai aussi vu que le code pouvait être optimisé.
Je ne me suis pas occupé des améliorations possibles mais j'ai ajouté la prise en charge de ces valeurs spécifiques : Null, Empty, "" ou chaîne vide.
Seule la fonction récursive change :

VB:
Private Function AbNotToTreeArray(ByRef treeAr As Variant, ByRef sAbNot As String, size As Integer, pos As Integer) As Integer
Dim idx As Integer, elt As Variant, isOpn As Boolean, i1 As Integer, v2 As Variant
    ReDim treeAr(size - 2)
    Do
        i1 = InStr(pos, sAbNot, "[")
        v2 = InStr(pos, sAbNot, "]")
        If (i1 > 0) Xor (v2 > 0) Then   'v1=Min(i1,v2) sauf si =0
            If i1 > v2 Then isOpn = True Else i1 = v2
        Else
            If i1 < v2 Then isOpn = True Else i1 = v2
        End If
        If i1 > pos Then
            v2 = Split(Mid(sAbNot, pos, i1 - pos + isOpn), ",")
            For Each elt In v2  'Type String par défaut
                If IsNumeric(elt) Then
                    elt = CInt(elt)  'Si val Numérique, conversion en Integer
                Else
                    If Len(elt) = 1 Then elt = Switch(elt = "$", "", elt = "@", Null, elt = "¤", Empty, True, elt)
                End If
                treeAr(idx) = elt: idx = idx + 1
            Next elt
        End If
        If isOpn Then  '[
            pos = AbNotToTreeArray(treeAr(idx), sAbNot, size - i1 + 1, i1 + 1)
            idx = idx + 1: isOpn = False
        Else
            ReDim Preserve treeAr(idx - 1)
            i1 = i1 + 1
            AbNotToTreeArray = IIf(Mid(sAbNot, i1, 1) = ",", i1 + 1, i1)
            Exit Function
        End If
    Loop Until False    'Sortie si Erreur ou i1=v2=0
End Function
Remarque : il est possible d'utiliser le symbole ", il suffit de le doubler comme cela "" mais pas les espaces ...
Voici un exemple pour utiliser toutes les valeurs spéciales :
treeAr = "[¤,$,@,0]": § treeAr

  • ¤ : Empty
  • $ : ""
  • @ : Null
Du coup ces symboles ne peuvent pas être affectés s'il n'y en a qu'un seul mais par contre pas de problème dans une valeur comportant plusieurs symboles.
0 affecte naturellement un type numérique Integer.
 

Lu76Fer

XLDnaute Occasionnel
Un 2ème Correctif :
Il y avait encore un soucis sur la fonction 'AbNotToTreeArray'; le calcul de la taille d'un tableau imbriqué était faux et nécessite une variable supplémentaire 'p0' qui permet de mémoriser la position initiale.
VB:
Dim idx As Integer, elt As Variant, isOpn As Boolean, i1 As Integer, v2 As Variant, p0 as Integer
    p0 = pos - 2    'Position initiale mémorisée
    ReDim treeAr(size - 2)
' (...)
        If isOpn Then  '[
            pos = AbNotToTreeArray(treeAr(idx), sAbNot, size - i1 + p0, i1 + 1)

Une fonction de suppression de 'blanc' sur mesure :
Voici une fonction qui permet de supprimer les espaces ou <Tab> sans pour autant enlever les espacements existants au niveau des valeurs.
Si je partage cette fonction c'est parce qu'elle peut être utilisée comme une base pour écrire des opérations sur une chaîne de caractère. Elle prend en charge les caractères étendus.

VB:
' Supprime les 'blancs' superflus dans une Notation Simplifiée de tableau arborescent
'   pTxt§ : notation en entrée
'   keepSpc (False par défaut) : si vrai, préserve les 'blancs' à gauche et droite des valeurs
' Retour : notation sans blanc superflu
Private Function DelSpcInTxt§(pTxt§ As String, Optional keepSpc As Boolean = False) As String
Dim yTxtIn() As Byte, yTxtOut() As Byte, loAsc As Byte, hiAsc As Byte, sbSep As Byte
Dim lenIn As Integer, posIn As Integer, posOut As Integer, bckOut As Integer, sbStx As Byte
'bckOut: position potentiel de retour arrière.  sbStx: symbol syntaxique = 1(,), 2([) ou 4(])
    yTxtIn = pTxt§ 'Charge la chaine dans un tableau de 'Byte'
    lenIn = UBound(yTxtIn): ReDim yTxtOut(lenIn): sbSep = Asc(§Sep)
  
    sbStx = 2 '[ pour éliminer des 'blancs' à Gauche
    While posIn < lenIn
        loAsc = yTxtIn(posIn): hiAsc = yTxtIn(posIn + 1)
        If hiAsc = 0 Then
            Select Case loAsc
            Case 9, 32: ' ' ou <Tab>
                If sbStx And Not (keepSpc) Then GoTo nextIn
                hiAsc = 255  '=> isSpc = True
            Case 44:    ' 1:,
                If keepSpc Then
                    If sbStx And 4 Then posOut = bckOut 'Si symbole précédent : ]
                End If: sbStx = 1
            Case 91:    ' 2:[
                If keepSpc Then
                    If sbStx And 3 Then posOut = bckOut 'Si symbole précédent : , ou [
                End If: sbStx = 2
            Case 93:    ' 4:]
                If keepSpc Then
                    If sbStx And 4 Then posOut = bckOut 'Si symbole précédent : ]
                End If: sbStx = 4
            Case Else:
                sbStx = 0
            End Select
            If Not (keepSpc) Then
                If sbStx And 5 Then posOut = bckOut
            End If
            yTxtOut(posOut) = loAsc: posOut = posOut + 2
            If hiAsc Then hiAsc = 0 Else bckOut = posOut 'si isSpc alors ReDo hiAsc sinon valide le flux
        Else
            yTxtOut(posOut) = loAsc: yTxtOut(posOut + 1) = hiAsc
            posOut = posOut + 2: bckOut = posOut: sbStx = 0
        End If
nextIn:
        posIn = posIn + 2
    Wend
    If sbStx > 0 Then posOut = bckOut
  
    ReDim Preserve yTxtOut(posOut - 1): DelSpcInTxt§ = yTxtOut
    Exit Function
End Function
Le principe de la fonction c'est de charger la chaîne dans un tableau de Byte et de parcourir ce tableau avec un pas de 2 car les caractères étendus sont stockés sur 2 octets : <loAsc><hiAsc>.
L'algorithme va simplement ignorer les blancs dans le cas ou il est sûr qu'il faut éliminer ces blancs. Et dans le cas où il faut connaître le symbole qui succède une série de blanc, une position de retour arrière 'bckout' permet de revenir dans le flux de sortie 'yTxtout(posOut)'.
 
Dernière édition:

Lu76Fer

XLDnaute Occasionnel
Merci Dranreb !

Je garde cela sous le coude . De mon côté, c'est un peu plus simple comme traitement car il n'y a qu'une gestion syntaxique de tableau imbriqué [ ] et si il y avait une grammaire plus complexe je serais plutôt parti sur une solution exploitant les expressions régulières 'RegExp'.
En faite, j'ai terminé une solution complète qui gère les dates, les chaînes , le type d'entier ou de décimal par défaut ainsi que les références d'objets.
Je vais partager cela plutôt dans les ressources et je mettrai le lien sur cette page.
 

Lu76Fer

XLDnaute Occasionnel
Le rangement en collection des éléments analysés pourrait néanmoins vous décharger des problèmes de dimensionnement du tableau.
stoechiometrie.xlsm : je ne sais pas s'il s'agissait de votre projet mais la présentation graphique est superbe !
Après examen je me suis rendu compte combien votre idée était pertinente . Quelle fulgurance !

J'ai implémenté une nouvelle version avec une collection ce qui change cependant un peu l'idée de départ qui était de créer un tableau arborescent de données et devient une collection arborescente de données.

En effet pour rester sur mon idée, il aurait fallu basculer les données de la collection au tableau ... Une autre solution serait d'utiliser un Dictionnaire ce qui obligerait à ajouter une référence externe au projet, et du coup je me suis dit que ce ne serait peut-être pas si pertinent. Reflexion in progress .......

Voici le code :
VB:
'Routine appelante de "Txt§To§" : Notation Abrégée = Txt§ -> Tree Collection = §.
'   pTxt§ : Notation abrégée = "[{val}|{#objName}|{Txt§},{val}|{#objName}|{Txt§},(...)]"
'       ex : "[4, 7, 5,[4, 6,[titi , Gros-Minet], 8] ]"    rem. : pas de guillemet pour les chaines
'Retour : Collection Arborescente de données §
'   et Nothing en cas d'erreur syntaxique en entrée
Function §(sTxt§ As String) As Collection
Dim pos As Integer, size As Integer
    On Error GoTo badSyntax
    sTxt§ = DelSpcInTxt§(sTxt§)
    size = Len(sTxt§)
    pos = 2
    Set § = Txt§To§(sTxt§, pos)
    If pos <> (size + 1) Then GoTo badSyntax
    Exit Function
badSyntax:
    Set § = Nothing
End Function

'Fonction récursive permettant de convertir la Notation Abrégée 'pTxt§' en Tree Collection 'Txt§To§'
'   pos : 'position de lecture' dans 'pTxt§' (Attention, il faut 'passer' le 1er '[')
'Retour : Collection Arborescente de données §
Private Function Txt§To§(pTxt§ As String, ByRef pos As Integer) As Collection
Dim elt As Variant, isOpn As Boolean, i1 As Integer, v2 As Variant
    Set Txt§To§ = New Collection
    Do
        i1 = InStr(pos, pTxt§, "[")
        v2 = InStr(pos, pTxt§, "]")
        If (i1 > 0) Xor (v2 > 0) Then   'v1=Min(i1,v2) sauf si =0
            If i1 > v2 Then isOpn = True Else i1 = v2
        Else
            If i1 < v2 Then isOpn = True Else i1 = v2
        End If
        If i1 > pos Then
            v2 = Split(Mid(pTxt§, pos, i1 - pos + isOpn), ",")
            For Each elt In v2  'Type String par défaut
' Traitement de donnée
                If IsNumeric(elt) Then
                    elt = CInt(elt)  'Si val Numérique, conversion en Integer
                Else
                    If Len(elt) = 1 Then elt = Switch(elt = "$", "", elt = "@", Null, elt = "¤", Empty, True, elt)
                End If
                Txt§To§.Add elt
' Fin de traitement
            Next elt
        End If
        If isOpn Then  '[, tableau imbriqué
            pos = i1 + 1
            Txt§To§.Add Txt§To§(pTxt§, pos)
            isOpn = False
        Else    '] de Fin
            i1 = i1 + 1
            pos = IIf(Mid(pTxt§, i1, 1) = ",", i1 + 1, i1)
            Exit Function
        End If
    Loop Until False    'Sortie si Erreur ou i1=v2=0
End Function
La fonction s'utilise du coup comme cela :
VB:
Dim cl As Collection, s As String
s = "  [8,-8,¤ ,  $, @,[[110,[[[5,87]]],1],8] , 0,[[[5,87],111],8] , 10 ,[[0,1],2]]  ": Set cl = §(s)
 

Lu76Fer

XLDnaute Occasionnel
Voici finalement la version révisée pour la fonction, routine § ainsi qu'une routine qui permet de convertir une Collection Arborescente en Tableau Arborescent :
VB:
'Routine ou Fonction appelante de "Txt§To§" : Notation Abrégée = Txt§ -> Tree Collection = §.
'   µ§ : Notation abrégée = "[{val}|{#objName}|{Txt§},{val}|{#objName}|{Txt§},(...)]"
'   toArray : si vrai converti la collection en tableau
'       ex : "[4, 7, 5,[4, 6,[titi , Gros-Minet], 8] ]"    rem. : pas de guillemet pour les chaines
'Retour : Collection Arborescente de données §
'ou(et) : Tableau Arborescent de données §
'      Nothing(Collection) et, ou Null(Array µ§) en cas d'erreur syntaxique en entrée
Function §(ByRef µ§ As Variant, Optional toArray As Boolean = False) As Collection
Dim sTxt§ As String, pos As Integer, size As Integer
    On Error GoTo badSyntax
    sTxt§ = CStr(µ§)
    sTxt§ = DelSpcInTxt§(sTxt§)
    size = Len(sTxt§)
    pos = 2
    Set § = Txt§To§(sTxt§, pos)
    If pos <> (size + 1) Then GoTo badSyntax
    If toArray Then Cl§To§ §, µ§
    Exit Function
badSyntax:
    If toArray Then µ§ = Null
    Set § = Nothing
End Function

'Routine qui convertie une Collection Arborescente en un Tableau Arborescent
'   pCl§ : la Collection Arborescente
'   ar§  : le Tableau Arborescent en retour
Private Sub Cl§To§(pCl§ As Collection, ByRef ar§ As Variant)
Dim elt As Variant, cnt As Integer, tot As Integer
    tot = pCl§.Count
    ReDim ar§(tot - 1)
    For cnt = 1 To tot
        If IsObject(pCl§(cnt)) Then Cl§To§ pCl§(cnt), ar§(cnt - 1) Else ar§(cnt - 1) = pCl§(cnt)
    Next cnt
End Sub

Il est donc possible de récupérer une collection cl§ comme ceci :
VB:
Dim cl§ As Collection, s As String
s = "  [8,-8,¤ ,  $, @,[[110,[[[5,87]]],1],8] , 0,[[[5,87],111],8] , 10 ,[[0,1],2]]  "
Set cl§ = §(s)
Ou de récupérer un tableau ar§ :
VB:
Dim ar§ As Variant
ar§ = "  [8,-8,¤ ,  $, @,[[110,[[[5,87]]],1],8] , 0,[[[5,87],111],8] , 10 ,[[0,1],2]]  "
§ ar§, True
Ou les deux
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…