Microsoft 365 Affecter des valeurs à 2 variables tableau en comparant 2 séquences d'éléments pour remplir une colonne

[klin89]

Bonjour à tous,

J'essaie de remplir la colonne C du tableau ci-dessous en comparant 2 séquences d'éléments.
La première séquence de 2 éléments se situe en colonne A et B à partir de la ligne 3.
La 2ème séquence se trouve dans la plage E1:N1
Exemple, je prends les 2 éléments situées en A3:B3 soit 1 et 2 pour les éliminer de la séquence E1:N1.
Les 3 éléments restants soit 3,4 et 5 doivent alors être dispatchés successivement en colonne C au regard de toutes les lignes comportant les éléments 1 et 2 en colonnes A et B

Autre exemple, en ligne 16, on trouve 4 et 2 qui devra renvoyer 3,5,1 dans cet ordre.
Autre exemple, en ligne 9, on trouve 2 et 4 qui devra renvoyer 5,1,3 dans cet ordre.
Précision, dans la plage E1:N1, l'élément de la colonne B constitue toujours le point de départ pour constituer la suite des éléments manquants, c'est pour ça que l'ordre diffère comme illustré ligne 9 et 16.

Pour bien comprendre, j'ai mis en colonne R les éléments qui doivent être renvoyés en colonne C pour chaque couple se trouvant en colonnes A et B.

Pouvez-vous m'aider à résoudre ce problème ?
D'avance merci.
klin89

 

[laurent950]

Bonsoir @klin89

Sub RemplirColonneC()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim rngSeq As Range, cell As Range, cellP As Range
    Dim elementsManquants As String, elementsManquantsR As String, elementsManquantsP As String
    Dim cpt As Byte
    
    ' Spécifiez la feuille de calcul
    Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
    
    ' Trouver la dernière ligne utilisée en colonne A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Boucle à travers chaque ligne à partir de la 3ème
    For i = 3 To lastRow
        ' Séquence actuelle en colonne A et B
        Set rngSeq = ws.Range("A" & i & ":B" & i)
        
        ' Réinitialiser les chaînes d'éléments manquants
        elementsManquants = "": elementsManquantsR = "": elementsManquantsP = ""
        cpt = 1
        
        ' Boucle à travers la plage E1:N1
        For Each cell In ws.Range("E1:N1")
            If cell.Value = rngSeq.Cells(1, 2).Value Then
                ' Ajouter l'élément de la colonne correspondante à la chaîne
                elementsManquants = cell.Offset(0, 1).Value
                ' Ajouter les éléments de la colonne P correspondante à la chaîne
                For Each cellP In ws.Range(cell.Offset(0, 1).Address & ":N1")
                    If cpt <= 3 And rngSeq(1, 1).Value2 <> cellP.Value And rngSeq(1, 2).Value2 <> cellP.Value2 Then
                        elementsManquantsP = elementsManquantsP & cellP.Value & ","
                        cpt = cpt + 1
                    End If
                Next cellP
                Exit For
            End If
        Next cell
        
        ' Remplir les colonnes C, P, et R avec les éléments manquants
        rngSeq.Cells(1, 3).Value = elementsManquants
        rngSeq.Cells(1, 16).Value = CStr(rngSeq(1, 1).Value2) & "," & CStr(rngSeq(1, 2).Value2)
        rngSeq.Cells(1, 18).Value = Left(elementsManquantsP, Len(elementsManquantsP) - 1)
    Next i
End Sub

 

[klin89]

Bonsoir laurent950,

Merci de ta réponse.
Je viens de tester, malheureusement cela ne me renvoie pas le résultat escompté.
Vois l'image ci-dessous :

Pour bien visualiser, j'ai filtré sur les colonnes A et B avec les éléments 1 et 2
La dernière colonne est le résultat souhaité (en vert)
Ce que renvoie ta macro est dans la colonne C
Dans le fichier du post #1#, la feuille "resultat" donne le résultat souhaité sur la totalité du tableau.
Il faut filtrer la colonne A et B pour bien visualiser.

klin89

 

[klin89]

re à tous

J'ai franchi une première étape via le code ci-dessous.
Me reste à trouver les 3 valeurs restantes en m'appuyant sur la variable tableau "result".

Comme vous le voyez dans la fenêtre exécution, j'obtiens le tableau "result" en supprimant les 2 éléments (4,2) du tableau arr.
De cette nouvelle séquence, je souhaite récupérer les 3 éléments en jaune qui sont la suite logique de l'élément situé en dernière position dans la variable "aSupprimer" soit le "2" dans l'exemple.
Pour résumé, 3 est le 1er élément supérieur à 2 dans la séquence "result"

Le code dans le module 1 :

Sub FilterArray()
    Dim aSupprimer As Variant
    Dim arr As Variant
    Dim result As Variant
    Dim item As Variant
    
    ' Définir les éléments à supprimer dans la sequence
    aSupprimer = Array(4, 2)
    
    ' Définir le tableau initial (la sequence)
    arr = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
    
    ' Redimensionner le tableau résultant
    ReDim result(0 To UBound(arr))
    Dim index As Integer
    index = 0
    ' obtenir les éléments restants
    For Each item In arr
        If Not IsInArray(item, aSupprimer) Then
            result(index) = item
            index = index + 1
        End If
    Next item
    
    ' Redimensionner le tableau résultant pour éliminer les éléments non utilisés
    ReDim Preserve result(0 To index - 1)
    
    ' Afficher les éléments restants dans la fenetre execution
    Debug.Print Join(result, ", "); ""
End Sub

Function IsInArray(val As Variant, arr As Variant) As Boolean
    ' Vérifier si val est dans le tableau arr
    Dim item As Variant
    For Each item In arr
        If item = val Then
            IsInArray = True
            Exit Function
        End If
    Next item
    IsInArray = False
End Function

Pouvez-vous m'aider à extraire ces 3 éléments restants à partir de la variable result ?
klin89

 

[zebanx]

Bonsoir Klin89, le forum

@klin89
Je n'ai pas codé mais en regardant les séquences d'index à retrouver, il m'apparait sauf erreur 4 configurations suivant le spread entre les valeurs x1 et x2 à supprimer.
Comme tu l'as indiqué au premier post, la référence c'est la position dans l'index de x2. Mais le spread entre x1 et x2 conduit à ne pas avoir des séquences identiques.
Après, il faudrait utiliser un mod(valeur,10) pour ne pas dépasser la valeur max de l'index(10).

En synthétisant :
- On ne cherche pas à supprimer des positions d'index dans l'array
- On recherche toutefois les positions de x1 et x2 et cela nous donne un spread qu'on conserve
- On va suivant la valeur de ce spread appliquer l'une des 4 formules (avec un mod(valeur,10)) pour avoir la séquence d'index recherchée à afficher (y1,y2,y3)

C'est plus clair avec le fichier.
En espérant que cela te donne des idées de direction pour coder -)

Xlment
zebanx

 

[klin89]

Bonsoir zebanx et merci de ta réponse,

Là, j'ai mal à mes neurones
Je t'avouerai que j'ai vraiment beaucoup de mal à comprendre tes explications.

J'illustre à nouveau en listant tous les exemples d'éléments à supprimer de la séquence initiale (colonne verte), pour ceux qui n'auraient pas saisi ma demande.

En colonne jaune, les éléments renvoyés suite à la suppression après exécution de la macro.
Dernière colonne, les 3 éléments à extraire dans une variable tableau issus de la variable result comme expliqué au post #4#

.
Encore une fois merci.
klin89

 

[RyuAutodidacte]

Coucou Klin89
Ca fait un moment …
pas sur d'avoir bien compris mais voilà ce que je propose pour remplir la colonne C de ce que j'ai compris avec les informations données :

Sub TestRotation()
Dim MySeq, DerL As Long, VA, x As Long, Cpt As Byte, i As Byte, StrSeq$
     MySeq = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
     DerL = Cells(Rows.Count, 1).End(xlUp).Row
     VA = Range("A3:C" & DerL).Value
     For x = LBound(VA) To UBound(VA)
        Cpt = 0
        For i = VA(x, 2) To UBound(MySeq)
            If MySeq(i) <> VA(x, 1) Then
                StrSeq = StrSeq & MySeq(i) & ","
                Cpt = Cpt + 1
            End If
            If Cpt = 3 Then Exit For
        Next
        VA(x, 3) = Mid(StrSeq, 1, 5):   StrSeq = ""
     Next
    VA = Application.Index(VA, Evaluate("Row(1:" & UBound(VA) & ")"), [{3}])
    Cells(3, 3).Resize(UBound(VA)).Value = VA
End Sub

 

[RyuAutodidacte]

Re,
Une version V2 et V3
le "x" est juste là pour la partie comprise mais qui ne commence pas par la valeur en colonne Bx

PS : a faire sur Feuil1 …

 

[RyuAutodidacte]

Bonjour @klin89 ,

il me semble, mais je peux me tromper si la partie orange est la séquence ok sur t'as capture alors pour :

si Bx commence à 5 on devrait avoir le second partie 123 en orange et pas la 1ère …
Qu'en est t-il ?

 

[klin89]

Bonjour RyuAutodidacte,

Après avoir lu et relu zebanx , j'ai revu ma position et laissé de côté mes explications du post #6#
J'ai trouvé le processus suivant pour obtenir le résultat souhaité.
Je l'illustre ci-dessous, ça sera plus simple.

étape 1 : de la séquence initiale, je ne retiens que les éléments à partir du 2ème élément de aSupprimer.

étape 2 : je vais supprimer les éléments de cette nouvelle séquence (ici en italique) via la macro du post #4#

étape 3 : j'obtiens alors ceci après la suppression.

étape 4 : je récupère les 3 premiers éléments de la nouvelle séquence via un redim preserve.

étape finale : pour chaque élément des colonne A et B, il ne me reste plus qu'à répartir les 3 éléments concernés en colonne C comme je l'indiquais dans le 1er post.
En espérant que ma démonstration soit plus clair.

RyuAutodidacte, je regarde ton travail et te redis, ne m'en veux pas si je ne réponds pas assez vite, j'ai la tête dans le guidon

klin89

 

[klin89]

Re RyuAutodidacte

Je tenais d'abord à te remercier pour ton implication.
J'ai testé tes 3 codes.
Visiblement, tu as compris le cheminement mais ce n'est pas tout à fait le résultat attendu.
Ta macro renvoie ceci :

et j'aimerais qu'elle me renvoie ceci, il faut que les 3 éléments soient répartis sur chaque ligne comme ci-dessous.

J'ai filtré sur la paire 1,4 en colonne A et B pour l'exemple.
précision : on retrouve 20 paires étalées 6 fois chacune soit sur 120 lignes.
20 = tous les arrangements de 2 parmi 5 éléments.

klin89
edit : demain je me lève à 3 heures du mat', ça m'étonnerait que je puisse vous répondre au cas où.

 

[RyuAutodidacte]

Voilà la V4

 

[gbinforme]

Bonjour à tous,

Voici la version que je propose et qui doit résoudre l'énigme de klin89

Public Sub rotation()
Dim idb As Integer
Dim idm As Integer
Dim idr As Integer
Dim tbb
Dim tbr
    tbb = Feuil1.Cells(3, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 2, 3).Value
    tbr = Feuil1.Range("E1:N1").Value
    For idb = 1 To UBound(tbb)
        If tbb(idb, 3) = "" Then
            ReDim tbm(1 To 1)
            For idr = 1 To UBound(tbr, 2)
                If tbr(1, idr) = tbb(idb, 2) Then Exit For
            Next idr
            For idr = idr + 1 To UBound(tbr, 2)
                If tbr(1, idr) <> tbb(idb, 1) And tbr(1, idr) <> tbb(idb, 2) Then
                    tbm(UBound(tbm)) = tbr(1, idr)
                    ReDim Preserve tbm(1 To UBound(tbm) + 1)
                End If
            Next idr
            idr = 1
            For idm = idb To UBound(tbb)
                If tbb(idm, 1) = tbb(idb, 1) And tbb(idm, 2) = tbb(idb, 2) Then
                    tbb(idm, 3) = tbm(idr)
                    idr = IIf(idr = UBound(tbm), 1, idr + 1)
                End If
            Next idm
        End If
    Next idb
    Feuil2.Activate
    Feuil2.Cells(3, 6).Resize(UBound(tbb), UBound(tbb, 2)).Value = tbb
End Sub

 

[RyuAutodidacte]

Ha je viens de comprendre la subtilité de ce que tu veux,
voilà la V5 tu pourras choisir ce que tu veux et le mettre ou tu veux
tu as tous les résultats ici

 

[klin89]

re à tous,

Post #12# : RyuAutodidacte, désolé mais ce n'est pas ça , vois la 2ème image au post#11#
gbinforme, tu as pigé la problématique et tu as réussi à constituer les 60 triplets sur 120 lignes.
3 arrangements parmi 5 = 60

Par contre, j'ai bien peur que ton code ne soit transposable pour remplir la 4ème colonne.
exemple avec le triplet {3,4,1}
Pourtant c'est exactement le même principe à adopter.

et c'est pour ça que je voyais la solution à travers le cheminement proposé au post #10#
En tout cas, merci à toi gbinforme

klin89
edit : la 5ème colonne, c'est pas difficile à la constituer avec une formule : 15 - somme (A), on trouve alors le dernier élément du tableau.