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

 

[klin89]

Re le forum

gbinforme, le code du post#40 me ressort un carré latin normalisé d'ordre 6 reproduit 120 fois
comme sur la 1ère image envoyée par Modeste geedee.
On ne retrouve que 6 permutations.
Normalement, les 720 lignes doivent renvoyer les 720 arrangements de 6 éléments, il ne doit pas y avoir de doublons.

RyuAutodidacte, oui aucun doublon sur les lignes, je le vérifie après avoir appliqué cette formule = CONCAT(A1:F1) dans une colonne adjacente, via le menu :

Accueil > Mise en forme conditionnelle > Règles de mise en surbrillance des cellules > valeur en doubles > Mettre en forme les cellules contenant des valeurs > uniques

Avec le code du post #36, je n'ai aucun doublon, je l'ai testé avec 4,5,6, et 7 éléments.
4 éléments --> 24 lignes
5 éléments --> 120 lignes
6 éléments --> 720 lignes
7 éléments --> 5040 lignes etc...
klin89

 

[Modeste geedee]

Bonsour

Normalement, les 720 lignes doivent renvoyer les 720 arrangements de 6 éléments, il ne doit pas y avoir de doublons.

Avec le code du post #36, je n'ai aucun doublon, je l'ai testé avec 4,5,6, et 7 éléments.
4 éléments --> 24 lignes
5 éléments --> 120 lignes
6 éléments --> 720 lignes
7 éléments --> 5040 lignes etc...

oui...

Normalement, les 720 lignes doivent renvoyer les 720 arrangements de 6 éléments, il ne doit pas y avoir de doublons.

mais non...
ne pas confondre carré latin et arrangements
un carré latin comporte des arrangements uniques et croisés de telle façon que aucun chiffre ne soit en double dans une même ligne ou colonne. avec des sommes en ligne ou colonne identiques (21)
la juxtaposition de 6 arrangements parmi 720 ne crée pas nécessairement un carré latin.

à partir d'un carré latin avéré
la permutation de 1 ou plusieurs lignes ou colonnes produit un autre carré latin.

il existerait donc autant de carrés latins différents que d'arrangements.
exemple :
6 carrés latins issus d'un seul composé de seulement 6 arrangements verticaux différents:
par permutation de colonnes produisent des arrangements horizontaux différents

 

[klin89]

re le forum,

J'ai repris le code du post #36 pour ne garder qu'un dictionnaire.
Exemple avec 4 éléments et 24 lignes.

On remplit la 1ère colonne

Sub Repeat()
' on remplit la 1ere colonne
' de la ligne 1 a 24 --> factorielle de 4
  [a1:a4].Value = [{1;2;3;4}]
  [a1:a4].AutoFill [A1:A24], xlFillCopy
End Sub

On remplit les 3 colonnes suivantes

Option Explicit
Sub carre_latin_ordre_4()
Dim i As Long, j As Byte, ii As Byte, ubEl As Byte, txt As String
Dim arr, seq, x, w, item, pos As Byte
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
seq = Array(1, 2, 3, 4, 1, 2, 3, 4)
Application.ScreenUpdating = False
With Sheets("Feuil1")
    For j = 1 To 3
        For i = 1 To 24
            arr = Application.index(.Range(.Cells(i, 1), .Cells(i, j)).Value, 1, 0)
            ubEl = arr(UBound(arr))
            txt = Join(arr, "")
            If Not dico.exists(txt) Then
                ReDim w(1 To 2)
                pos = Application.Match(ubEl, seq, 0)
                ReDim x(0 To UBound(seq) - pos + 1)
                For ii = pos To UBound(seq) + 1
                    x(ii - pos) = seq(ii - 1)
                Next
                ReDim result(0 To UBound(x))
                Dim index As Byte
                index = 0
                For Each item In x
                    If Not IsInArray(item, arr) Then
                        result(index) = item
                        index = index + 1
                    End If
                Next
                ReDim Preserve result(0 To 3 - j)
                w(1) = result: w(2) = 0
                dico(txt) = w
            End If
            'on récupère les 2 éléments de la clé concernée
            ' l'array w(1) et l'index w(2)
            w = dico(txt)
            'on récupère l'index
            index = w(2)
            'on ecrit dans la cellule l'element désigné par l'index
            .Cells(i, j + 1) = w(1)(index)
            index = index + 1
            If index = UBound(w(1)) + 1 Then index = 0
            'on associe le nouvel index à la clé
            w(2) = index
            dico(txt) = w
        Next
        dico.RemoveAll
    Next
End With
Set dico = Nothing
Application.ScreenUpdating = True
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

Et j'obtiens 6 carrés latins d'ordre 4
klin89

 

[RyuAutodidacte]

Hello @klin89
j'avais vu qu'au début tu avais mis mon post en résolu, puis tu avais changé d'avis avec ton nouveau code que tu as mis en résolu …
Voyons voir si ce qui suit peut te faire changer d'avis :
PS : Change juste la variable Nbre avec 2 , 3 , 4 , 5 , 6 , 7 … ce qui te convient

Sub PermutCombiArray()
Dim Seq, Fact As Long, x As Integer
Dim usedElements() As Boolean, currentPermutation, VA, rowIdx As Long

    Cells(2, 1).CurrentRegion.ClearContents
    Nbre = 4
    Seq = Application.Transpose(Evaluate("Row(1:" & Nbre & ")")):  x = Nbre
    Fact = 1:    Do While x <> 1:    Fact = x * Fact:     x = x - 1:    Loop
    
    ReDim usedElements(LBound(Seq) To UBound(Seq))
    ReDim currentPermutation(LBound(Seq) To UBound(Seq))
    ReDim VA(1 To Fact, 1 To Nbre)
    
    rowIdx = 1
    GetPermutCombiArray Seq, usedElements, currentPermutation, VA, rowIdx
    
    Cells(2, 1).Resize(UBound(VA), UBound(VA, 2)).Value = VA

End Sub
Sub GetPermutCombiArray(Seq, usedElements, currentPermutation, VA, rowIdx As Long, Optional currentPosition As Long = 1)
Dim i As Long, y As Long

    If currentPosition = UBound(Seq) + 1 Then
        For y = 1 To UBound(VA, 2)
            VA(rowIdx, y) = currentPermutation(y)
        Next
        rowIdx = rowIdx + 1
        Exit Sub
    End If

    For i = LBound(Seq) To UBound(Seq)
        If Not usedElements(i) Then
            usedElements(i) = True
            currentPermutation(currentPosition) = Seq(i)
            GetPermutCombiArray Seq, usedElements, currentPermutation, VA, rowIdx, currentPosition + 1
            usedElements(i) = False
        End If
    Next i
End Sub

 

[klin89]

Re RyuAutodidacte

Je viens de tester ton code du post #49 avec 3 éléments (à gauche sur l'image). Cela me renvoie bien les 6 permutations mais pas les 2 carrés latins d'ordre 3 souhaités.

A droite, j'obtiens 2 carrés latins d'ordre 3 avec le code du post #48.

klin89

 

[RyuAutodidacte]

Re RyuAutodidacte

Je viens de tester ton code du post #49 avec 3 éléments (à gauche sur l'image). Cela me renvoie bien les 6 permutations mais pas les 2 carrés latins d'ordre 3 souhaités.

A droite, j'obtiens 2 carrés latins d'ordre 3 avec le code du post #48.

Regarde la pièce jointe 1185751
klin89

Re

En effet j'ai toutes les combinaisons sans doublons mais il ne sont pas dans l'ordre pour faire directement le carré latin