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

klin89 · 12 Novembre 2023

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 · 21 Novembre 2023

Bonsoir à tous,

Oui, c'est bien le résultat attendu pour traiter la 3ème colonne.

klin89

RyuAutodidacte · 21 Novembre 2023

Re,

du coup qu'elle méthode vas tu utiliser ? au final …
Car il y a la 4è et 5 colonne …

klin89 · 22 Novembre 2023

Re à tous,

Pour en finir avec mon bricolage

Je crée la première colonne avec les 5 éléments sur 120 lignes

VB:

Sub Repeat()
' on remplit la 1ere colonne
' de la ligne 1 a 120
  [a1:a5].Value2 = [{1;2;3;4;5}]
  [a1:a5].AutoFill [A1:A120], xlFillCopy
End Sub

Puis je remplis la colonne B avec ce code, y'a plus qu'à appliquer le code sur les colonnes suivantes sur le même modèle.
J'ai créé un 2éme dictionnaire (dico2) pour cibler l'élément de la variable tableau associé à dico1.

VB:

Option Explicit
Sub test()
    Dim a, w, i As Long, ii As Byte
    Dim txt As String
    Dim dico1 As Object
    Dim dico2 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")
    Set dico2 = CreateObject("Scripting.Dictionary")
    ' tableau de 120 lignes en Feuille 1
    '120 = factorielle de 5
    a = Sheets("Feuil1").[a1].CurrentRegion.Resize(, 5).Value
    arr = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
    For i = 1 To UBound(a, 1)
        txt = a(i, 1) ' clé des 2 dictionnaires
        'txt = Join$(Array(a(i, 1), a(i, 2)), "")
        If Not dico1.exists(txt) Then
            ' etape 1 et 2
            asupprimer = Array(a(i, 1))
            'asupprimer = Array(a(i, 1), a(i, 2))
            pos = Application.Match(a(i, 1), arr, 0)
            '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
            ' les 4 elements a repartir sur la 2eme colonne
            ReDim Preserve result(0 To 3)
            'Debug.Print Join$(Array(a(i, 1))); ""
            'Debug.Print Join$(Array(a(i, 1), a(i, 2))); ""
            'Debug.Print Join(result, ", "); ""
            'on associe la variable tableau de 4 elements à la clé désignée
            dico1(txt) = result
            dico2(txt) = 0
        End If
    Next
    ' on remplit la colonne B
    For i = 1 To UBound(a, 1)
        txt = a(i, 1) ' la clé
        If dico1.exists(txt) Then
            'on récupère l'index de l'element à répartir
            index = dico2(txt)
            'on ecrit dans la cellule l'element désigné par l'index
            Sheets("Feuil1").Cells(i, 2) = dico1(txt)(index)
            index = index + 1
            If index = 4 Then index = 0
            'on associe le nouvel index à la clé pour répartir l'element suivant
            dico2(txt) = index
        End If
    Next
    Set dico1 = Nothing
    Set dico2 = Nothing
End Sub

VB:

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

Je crois que j'ai fait le tour et on peut considérer le sujet comme résolu.
Merci à toi RyuAutodidacte

klin89

RyuAutodidacte · 22 Novembre 2023

klin89 à dit:
Merci à toi RyuAutodidacte

Hello
au plaisir

klin89 · 25 Novembre 2023

Re le forum,

Pour ne pas en rester là, j'ai finalisé mon bricolage

Ici on remplit la 1ère colonne.

VB:

Sub Repeat()
' on remplit la 1ere colonne
' de la ligne 1 a 120
  [a1:a5].Value = [{1;2;3;4;5}]
  [a1:a5].AutoFill [A1:A120], xlFillCopy
End Sub

Là on remplit les 4 colonnes suivantes, on forme ainsi 24 carrés latins d'ordre 5.

VB:

Option Explicit
Sub carre_latin_ordre_5()
Dim i As Long, j As Byte, ii As Byte, ubEl As Byte, txt As String
Dim arr, seq, w, item, pos As Byte
Dim dico1 As Object, dico2 As Object
Set dico1 = CreateObject("Scripting.Dictionary")
Set dico2 = CreateObject("Scripting.Dictionary")
seq = Array(1, 2, 3, 4, 5, 1, 2, 3, 4, 5)
With Sheets("Feuil1")
    For j = 1 To 4
        For i = 1 To 120
            arr = Application.index(.Range(.Cells(i, 1), .Cells(i, j)).Value, 1, 0)
            ubEl = arr(UBound(arr))
            txt = Join(arr, "")
            If Not dico1.exists(txt) Then
                pos = Application.Match(ubEl, seq, 0)
                ReDim w(0 To UBound(seq) - pos + 1)
                For ii = pos To UBound(seq) + 1
                    w(ii - pos) = seq(ii - 1)
                Next
                ReDim result(0 To UBound(w))
                Dim index As Byte
                index = 0
                For Each item In w
                    If Not IsInArray(item, arr) Then
                        result(index) = item
                        index = index + 1
                    End If
                Next
                ReDim Preserve result(0 To 4 - j)
                dico1(txt) = result
                dico2(txt) = 0
            End If
        Next
        For i = 1 To 120
            arr = Application.index(.Range(.Cells(i, 1), .Cells(i, j)).Value, 1, 0)
            txt = Join(arr, "")
            If dico1.exists(txt) Then
                'on récupère l'index de l'element
                index = dico2(txt)
                'on ecrit dans la cellule l'element désigné par l'index
                .Cells(i, j + 1) = dico1(txt)(index)
                index = index + 1
                If index = UBound(dico1(txt)) + 1 Then index = 0
                'on associe le nouvel index à la clé
                dico2(txt) = index
            End If
        Next
        dico1.RemoveAll
        dico2.RemoveAll
    Next
End With
Set dico1 = Nothing
Set dico2 = Nothing
End Sub

VB:

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

klin89 · 26 Novembre 2023

Re à tous

J'ai réajusté le code du post#35 en supprimant la dernière boucle qui était inutile

Exemple avec 6 éléments et 720 lignes.

On remplit la 1ère colonne.

VB:

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

On remplit les 5 colonnes suivantes..

VB:

Option Explicit

Sub carre_latin_ordre_6()
Dim i As Long, j As Byte, ii As Byte, ubEl As Byte, txt As String
Dim arr, seq, w, item, pos As Byte
Dim dico1 As Object, dico2 As Object
Set dico1 = CreateObject("Scripting.Dictionary")
Set dico2 = CreateObject("Scripting.Dictionary")
seq = Array(1, 2, 3, 4, 5, 6, 1, 2, 3, 4, 5, 6)
Application.ScreenUpdating = False
With Sheets("Feuil1")
    For j = 1 To 5
        For i = 1 To 720
            arr = Application.index(.Range(.Cells(i, 1), .Cells(i, j)).Value, 1, 0)
            ubEl = arr(UBound(arr))
            txt = Join(arr, "")
            If Not dico1.exists(txt) Then
                pos = Application.Match(ubEl, seq, 0)
                ReDim w(0 To UBound(seq) - pos + 1)
                For ii = pos To UBound(seq) + 1
                    w(ii - pos) = seq(ii - 1)
                Next
                ReDim result(0 To UBound(w))
                Dim index As Byte
                index = 0
                For Each item In w
                    If Not IsInArray(item, arr) Then
                        result(index) = item
                        index = index + 1
                    End If
                Next
                ReDim Preserve result(0 To 5 - j)
                dico1(txt) = result
                dico2(txt) = 0
            End If
            'on récupère l'index de l'element
            index = dico2(txt)
            'on ecrit dans la cellule l'element désigné par l'index
            .Cells(i, j + 1) = dico1(txt)(index)
            index = index + 1
            If index = UBound(dico1(txt)) + 1 Then index = 0
            'on associe le nouvel index à la clé
            dico2(txt) = index
        Next
        dico1.RemoveAll
        dico2.RemoveAll
    Next
End With
Set dico1 = Nothing
Set dico2 = Nothing
Application.ScreenUpdating = True
End Sub

VB:

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 120 carrés latins d'ordre 6
klin89

RyuAutodidacte · 26 Novembre 2023

Hello klin89

il me semble que l'on s'était arrêté à 5
Peux tu me donner les règles pour 6 …?
les données sont le mêmes ? il me semble pas car si on augmente à 6 ça augmente le nbre de carrés latin… ? si c'est le cas tu peux me les redonner stp

klin89 · 26 Novembre 2023

Re RyuAutodidacte

Pour te répondre : exemple avec 720 carrés latins d'ordre 7 soit 5040 lignes.

Je remplace ceci : (carré latin d'ordre 6)

VB:

seq = Array(1, 2, 3, 4, 5, 6, 1, 2, 3, 4, 5, 6)

par cela : (carré latin d'ordre 7)

VB:

seq = Array(1, 2, 3, 4, 5, 6, 7, 1, 2, 3, 4, 5, 6, 7)

Ceci : (carré latin d'ordre 6)

VB:

 For j = 1 To 5
        For i = 1 To 720

par cela : (carré latin d'ordre 7)

VB:

 For j = 1 To 6
        For i = 1 To 5040

Ceci : (carré latin d'ordre 6)

VB:

 ReDim Preserve result(0 To 5 - j)

par cela : (carré latin d'ordre 7)

VB:

  ReDim Preserve result(0 To 6 - j)

Ceci : (carré latin d'ordre 6)

VB:

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

par cela : (carré latin d'ordre 7)

VB:

Sub Repeat()
' on remplit la 1ere colonne
' de la ligne 1 a 5040 --> factorielle de 7
  [a1:a7].Value = [{1;2;3;4;5;6;7}]
  [a1:a7].AutoFill [A1:A5040], xlFillCopy
End Sub

klin89

RyuAutodidacte · 26 Novembre 2023

Si on fait cela ca serait juste ?

VB:

Sub Repeat()
' on remplit la 1ere colonne
' de la ligne 1 a 5040 --> factorielle de 7
    [a1:a7].Value = [{1;2;3;4;5;6;7}]
    [a1:a7].AutoFill [A1:A5040], xlFillCopy
    [b1:b7].Value = [{2;3;4;5;6;7;1}]
    [b1:b7].AutoFill [B1:B5040], xlFillCopy
    [c1:c7].Value = [{3;4;5;6;7;1;2}]
    [c1:c7].AutoFill [C1:C5040], xlFillCopy
    [d1:d7].Value = [{4;5;6;7;1;2;3}]
    [d1:d7].AutoFill [D1:D5040], xlFillCopy
End Sub

Peut être faut il aller jusqu'à la colonne E ?

Edit : vérifier avec les données des 2 Colonnes que tu m'avais donnée ce n'est pas ok pour les autres colonnes (2 à 4)

gbinforme · 26 Novembre 2023

Bonjour à tous,

Si j'ai bien compris les carrés latins il me semble qu'il n'y pas besoin de beaucoup de code pour les créer.
En ce qui me concerne je les crée ainsi :

VB:

Public Sub carré()
Const nbc = 120     ' nombre de carrés
Const nbk = 6       ' nombre de colonnes
Dim col As Long     ' colonne
Dim lig As Long     ' ligne
Dim num As Long     ' numéro début ligne
    With Feuil2     ' à adapter
        .Cells(1, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, nbk).ClearContents
        For lig = 1 To nbc * nbk
            num = lig Mod nbk
            .Cells(lig, 1).Value = IIf(num = 0, nbk, num)
            For col = 2 To nbk
                .Cells(lig, col).Value = IIf(.Cells(lig, col - 1).Value >= nbk, 1, .Cells(lig, col - 1).Value + 1)
            Next col
        Next lig
    End With
End Sub

RyuAutodidacte · 26 Novembre 2023

Bonjour @gbinforme (@klin89)

J'ai testé le code avec :

VB:

Const nbc = 120     ' nombre de carrés
Const nbk = 5       ' nombre de colonnes

@kling avec une séquence de 5 me donne un nombre de 120 possibilités maxi (si j'ai bien compris),
La je me suis retrouvé avec 600 lignes. Est ce normal ? à moins que j'ai mal utilisé le code … ?

Edit : et si je supprime les doublons, il ne me reste que 6 lignes

RyuAutodidacte · 26 Novembre 2023

@klin89
pour la sequence de 5 les règles étaient (départ avec 2 colonnes remplis) :

on se base sur le chiffre de la 2è colonne pour commencer à partir de ce chiffre + 1 dans la séquence
on se base sur le chiffre de la 3è colonne pour commencer à partir de ce chiffre + 1 dans la séquence
on fait une opération de 15 - les 4 1er chiffres pour trouver le 5è chiffre

Qu'en est-il avec séquence 6 et 7 ?

RyuAutodidacte · 26 Novembre 2023

@klin89 ,

je t'ai fait une function pour la 1ère colonne, c'est automatique :

VB:

Sub FirstColCarLat()
    FirstColCarreLatin 5, 2
End Sub

Function FirstColCarreLatin(ByVal Nbre As Long, Optional ByVal Lig As Integer)
Dim Seq, fact As Long, x As Integer
    Seq = Evaluate("Row(1:" & Nbre & ")"):  x = Nbre
    fact = 1:    Do While x <> 1:    fact = x * fact:     x = x - 1:    Loop
    If Lig = 0 Then Lig = 1
    Range("A" & Lig & ":A" & Nbre + Lig - 1).Value = Seq
    Range("A" & Lig & ":A" & Nbre + Lig - 1).AutoFill Range("A" & Lig & ":A" & fact + Lig - 1), xlFillCopy
End Function

Nbre => jusqu'à quel nombre tu veux
Lig => facultatif, commence à la ligne que tu veux

Modeste geedee · 26 Novembre 2023

Bonsour®

gbinforme à dit:
Si j'ai bien compris les carrés latins il me semble qu'il n'y pas besoin de beaucoup de code pour les créer.

sans code !!!
à partir d'un carré latin implicite

RyuAutodidacte · 26 Novembre 2023

re @klin89

j'ai testé ton code en passant par mon dictionnaire (Mac) et cela m'a fourni des carré latin sur 6 colonnes et 720 lignes
j'ai voulu ensuite supprimer les doublons (il me semble que normalement il ne doit pas y en avoir) via "Supprimer les doublon" de l'onglet "Données"
il ne me reste plus que 450 lignes (une erreur de transpositions de mon dico dans ton code ??)
qu'en est il de ton coté ?

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

XLDnaute Accro

Pièces jointes

XLDnaute Accro

XLDnaute Impliqué

XLDnaute Accro

XLDnaute Impliqué

XLDnaute Accro

XLDnaute Accro

XLDnaute Impliqué

XLDnaute Accro

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

Discussions similaires

Partager cette page

Statistiques des forums