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

 

[RyuAutodidacte]

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
Regarde la pièce jointe 1183880

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.
Regarde la pièce jointe 1183881
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.

tu n'as pas vu la V5

 

[RyuAutodidacte]

Re, si tu veux déplacer ton résultat avec les 3 colonnes il suffit de faire :

    VB = Application.Index(VA, Evaluate("Row(1:" & UBound(VA) & ")"), [{1,2,3}])
    Cells(x_deTaCell, y_deTaCell).Resize(UBound(VA), 3).Value = VB
    ' j'ai schématisé l'adresse de ta cell avec Cells(x_deTaCell, y_deTaCell)

 

[RyuAutodidacte]

Par contre, j'ai bien peur que ton code ne soit transposable pour remplir la 4ème colonne.

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.

Il me semble pas que la 4è et 5ème colonne aient été exposé dans les explication de départ … ???

 

[RyuAutodidacte]

@klin89

Grande nouvelle ou pas … ?
C'est bien ça que tu veux (fais via ma dernière macro … non posté pour le moment) ?

Concernant la colonne 5 pas compris avec le Smilé qui cache le sens avec la somme …
… ?????

aller une autre capture pour confirmer ou infirmer … ????

PS : Remet ta formule avec la balise code et les explications pour la colonne 5 stp comment elle est obtenu … ? merci

 

[klin89]

Re,

Je réponds de mon téléphone portable, c'est pas simple, je suis au boulot.
Au final chaque ligne comportera 5 éléments dont la somme sera égale à 15 comme dans un carré latin. Donc le dernier élément sera bien égal à 15 - la somme des 4 premiers éléments.
{1,4,5} doit renvoyer {2,3} comme sur ta capture et comme illustré au post #15#
Il n'y a pas de doublons sur une ligne, c'est logique.
1+2+3+4+5=15

Klin89

 

[RyuAutodidacte]

Je pense que l'on est bon là :

Si besoin d'explications sur le code n'hésite pas

 

[RyuAutodidacte]

Hello @klin89

Pas de nouvelle bonne nouvelle ? est ce ok, ou ai je omis qq chose ?

 

[klin89]

Bonsoir à tous,

Tu vas finir par t'arracher les cheveux, désolé.
On a 120 lignes qui représente 24 carrés latins d'ordre 5.
120 = factorielle de 5
Après exécution de la macro, on voit ici le le 1er carré latin
les lignes et les colonnes ne doivent pas contenir de doublons et leur somme doit être égale à 15
Ici il y a des doublons en colonne 4 et 5 et la somme de ces 2 colonnes n'est pas égale à 15.

le 1er carre latin devrait ressembler à celui-là

On le voit après ce filtre, la colonne 3 devrait renvoyer {4,5,1} comme indiqué dans séquence 1 alors qu'elle renvoie {5,1,4}

klin89

 

[RyuAutodidacte]

Re @klin89

En fait mon code est bon (enfin j'espère ),
j'ai juste fait une erreur de placement du On Error Resume Next

Le code corrigé en mouvant la ligne concernée (avec On Error Resume Next)

Option Explicit
Sub TestRotationV4()
Dim MySeq, DerL As Long, VA, x As Long, Cpt As Byte, i As Byte, TbSeq, ColSeq As New Collection, cle$, CptSeq As Byte, VB

     MySeq = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
     DerL = Cells(Rows.Count, 1).End(xlUp).Row
  
     Range("C2:G" & DerL).ClearContents:        Range("AG2:AK" & DerL).ClearContents
     MsgBox "Suppression des lignes pour démo"
  
     VA = Range("A2:L" & DerL).Value
  
    For x = LBound(VA) To UBound(VA)
        '----------------------------------------------------------------------------------------------------------------------------
        On Error Resume Next
        cle = VA(x, 1) & VA(x, 2) & "C3":      ColSeq.Add 1, cle
        If Err Then Err.Clear:      CptSeq = ColSeq(cle):       ColSeq.Remove (cle):       ColSeq.Add IIf(CptSeq = 3, 1, CptSeq + 1), cle
      
        Cpt = 0:    ReDim TbSeq(1 To 5)
        For i = VA(x, 2) To UBound(MySeq)
            If MySeq(i) <> VA(x, 1) Then
                Cpt = Cpt + 1:      TbSeq(Cpt) = MySeq(i)
            End If
        If Cpt = 3 Then Exit For
        Next
        VA(x, 3) = TbSeq(ColSeq(cle)):      VA(x, 6) = Mid(Join(TbSeq, ","), 1, 5):      VA(x, 8) = TbSeq(1):        VA(x, 9) = TbSeq(2):        VA(x, 10) = TbSeq(3)
      
        '----------------------------------------------------------------------------------------------------------------------------
        cle = VA(x, 1) & VA(x, 2) & VA(x, 3) & "C4":      ColSeq.Add 4, cle
        If Err Then Err.Clear:      CptSeq = ColSeq(cle):       ColSeq.Remove (cle):       ColSeq.Add IIf(CptSeq = 5, 4, CptSeq + 1), cle
      
        For i = VA(x, 3) To UBound(MySeq)
            If MySeq(i) <> VA(x, 1) And MySeq(i) <> VA(x, 2) Then
                Cpt = Cpt + 1:      TbSeq(Cpt) = MySeq(i)
            End If
        If Cpt = 2 Then Exit For
        Next
        VA(x, 4) = TbSeq(ColSeq(cle)):      VA(x, 7) = Mid(Join(TbSeq, ","), 7):        VA(x, 11) = TbSeq(4):        VA(x, 12) = TbSeq(5)
     '----------------------------------------------------------------------------------------------------------------------------
        VA(x, 5) = 15 - (VA(x, 1) + VA(x, 2) + VA(x, 3) + VA(x, 4))
    Next
  
     ' Reprise des col 3, 4 et 5 dans le tableau VA
    VB = Application.Index(VA, Evaluate("Row(1:" & UBound(VA) & ")"), [{3,4,5}])
    Cells(2, 3).Resize(UBound(VA), 3).Value = VB
    ' Reprise des séquences 1 et 2 dans le tableau VA en col 6 et 7
    VB = Application.Index(VA, Evaluate("Row(1:" & UBound(VA) & ")"), [{6,7}])
    Cells(2, 6).Resize(UBound(VA), 2).Value = VB
    ' Reprise de chaque éléments dans les séquences1 et 2 dans le tableau VA en col 8 à 12 du tableau VA
    VB = Application.Index(VA, Evaluate("Row(1:" & UBound(VA) & ")"), [{8,9,10,11,12}])
    Cells(2, 33).Resize(UBound(VA), 5).Value = VB

End Sub

 

[RyuAutodidacte]

Hello @klin89

J'ai une méconnaissance des carrés latin, à quoi cela peut servir dans la vie de tous les jours ?

PS : la correction du code à tout réglé ou il y a encore qq chose ?

 

[klin89]

Bonjour à tous,

Ce coup ci, ça m'a l'air d'être tout bon RyuAutodidacte
J'ai 120 lignes avec toutes les permutations de 5 éléments qui forment 24 carrés latins d'ordre 5.
Pour chaque carré, la somme des colonnes et des lignes est égale à 15 et je n'ai aucun doublon dans les 120 permutations (vérification faite avec une mise en forme conditionnelle)

Ton code est donc transposable avec 4 éléments.
Je pars avec 24 lignes (factorielle de 4), la 1ère colonne étant rempli manuellement de la suite 1,2,3,4 (6 fois)
et selon le même principe, on remplit les 3 colonnes suivantes pour obtenir 6 carrés latins dont la somme de chaque colonne et ligne est égale à 10.

klin89

 

[RyuAutodidacte]

Hello @klin89

Ce coup ci, ça m'a l'air d'être tout bon RyuAutodidacte

comme quoi déplacé une ligne de code ca fait tout

Du coup le poste est résolu ? (il n'est pas marqué comme tel)

J'ai une méconnaissance des carrés latin, à quoi cela peut servir dans la vie de tous les jours ?

Pas eu de réponse sur ci-dessus …

Ryu

 

[klin89]

Re RyuAutodidacte,

Je réponds de mon téléphone portable.
En fait, je constitue des équipes et génére des plannings.
Par exemple, je forme avec les 2 premières colonnes des binômes {1,2} et {4 5} que je remplace par le nom d'employés.
Ensuite avec l'autre partie (les autres colonnes), je fais de même, je remplace les nombres par d'autres noms d'employés.
1 nombre = 1 nom
Après une ligne peut correspondre à un poste ou à un jour de semaine.
On peut décliner de différentes manières.
Ici le tableau ne fait que 5 colonnes, il pourrait y en avoir plus.
Klin89

 

[klin89]

Re le forum,

Voilà le code qui illustre le cheminement du post #10# que je souhaitais adopter.
Résultat dans la fenêtre exécution.

Option Explicit
Sub test()
    Dim a, w, i As Long, ii As Byte
    Dim txt As String
    Dim dico1 As Object
    Dim arr As Variant
    Dim asupprimer As Variant
    Dim pos As Byte
    Dim result As Variant
    Dim item As Variant
    Set dico1 = CreateObject("Scripting.Dictionary")
    a = Sheets("Feuil1").[a2].CurrentRegion.Value
    arr = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
    For i = 2 To UBound(a, 1)
        txt = Join$(Array(a(i, 1), a(i, 2)), "")
        If Not dico1.exists(txt) Then
            ' etape 1 et 2
            asupprimer = Array(a(i, 1), a(i, 2))
            pos = Application.Match(a(i, 2), arr, 0)
            ReDim w(0 To UBound(arr) - pos + 1)
            For ii = pos To UBound(arr) + 1
                w(ii - pos) = arr(ii - 1)
            Next
            ' etape 3
            ReDim result(0 To UBound(w))
            Dim index As Byte
            index = 0
            For Each item In w
                If Not IsInArray(item, asupprimer) Then
                    result(index) = item
                    index = index + 1
                End If
            Next item
            ReDim Preserve result(0 To index - 1)
            ' etape 4
            ReDim Preserve result(0 To 2)
            Debug.Print Join$(Array(a(i, 1), a(i, 2))); ""
            Debug.Print Join(result, ", "); ""
            dico1(txt) = result
        End If
    Next
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

klin89

 

[RyuAutodidacte]

Re le forum,

Voilà le code qui illustre le cheminement du post #10# que je souhaitais adopter.
Résultat dans la fenêtre exécution.

Option Explicit
Sub test()
    Dim a, w, i As Long, ii As Byte
    Dim txt As String
    Dim dico1 As Object
    Dim arr As Variant
    Dim asupprimer As Variant
    Dim pos As Byte
    Dim result As Variant
    Dim item As Variant
    Set dico1 = CreateObject("Scripting.Dictionary")
    a = Sheets("Feuil1").[a2].CurrentRegion.Value
    arr = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
    For i = 2 To UBound(a, 1)
        txt = Join$(Array(a(i, 1), a(i, 2)), "")
        If Not dico1.exists(txt) Then
            ' etape 1 et 2
            asupprimer = Array(a(i, 1), a(i, 2))
            pos = Application.Match(a(i, 2), arr, 0)
            ReDim w(0 To UBound(arr) - pos + 1)
            For ii = pos To UBound(arr) + 1
                w(ii - pos) = arr(ii - 1)
            Next
            ' etape 3
            ReDim result(0 To UBound(w))
            Dim index As Byte
            index = 0
            For Each item In w
                If Not IsInArray(item, asupprimer) Then
                    result(index) = item
                    index = index + 1
                End If
            Next item
            ReDim Preserve result(0 To index - 1)
            ' etape 4
            ReDim Preserve result(0 To 2)
            Debug.Print Join$(Array(a(i, 1), a(i, 2))); ""
            Debug.Print Join(result, ", "); ""
            dico1(txt) = result
        End If
    Next
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

klin89

Bonjour @klin89 ,

Je suis sur Mac donc j'ai pas accès au dico Windows (c'est pour cela que j'ai utilisé une collection qui fait la même chose et qui marche sur les 2 plateforme)
J'ai adapté ton code en conséquence, mais pour être sur, c'est bien ce résultat que tu dois avoir ??? :

2 3
4, 5, 1
3 4
5, 1, 2
4 5
1, 2, 3
5 1
2, 3, 4
1 3
4, 5, 2
2 4
5, 1, 3
3 5
1, 2, 4
4 1
2, 3, 5
5 2
3, 4, 1
1 4
5, 2, 3
2 5
1, 3, 4
3 1
2, 4, 5
4 2
3, 5, 1
5 3
4, 1, 2
1 5
2, 3, 4
2 1
3, 4, 5
3 2
4, 5, 1
4 3
5, 1, 2
5 4
1, 2, 3
1 2
3, 4, 5