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

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

klin89

XLDnaute Accro
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
 

Pièces jointes

  • rotation_v1.xlsm
    15.3 KB · Affichages: 10
Dernière édition:
Solution
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...
Trier par date Trier par votes

klin89

XLDnaute Accro
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
 
Dernière édition:
Vote positif 0 Vote négatif

klin89

XLDnaute Accro
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
 
Vote positif 0 Vote négatif

klin89

XLDnaute Accro
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
 
Dernière édition:
Vote positif 0 Vote négatif
Solution

RyuAutodidacte

XLDnaute Impliqué
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
 
Vote positif 0 Vote négatif

klin89

XLDnaute Accro
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
 
Dernière édition:
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
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)
 
Dernière édition:
Vote positif 0 Vote négatif
G

gbinforme

XLDnaute Impliqué
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
 
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
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
 
Dernière édition:
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
@klin89
pour la sequence de 5 les règles étaient (départ avec 2 colonnes remplis) :
  1. on se base sur le chiffre de la 2è colonne pour commencer à partir de ce chiffre + 1 dans la séquence
  2. on se base sur le chiffre de la 3è colonne pour commencer à partir de ce chiffre + 1 dans la séquence
  3. 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 ?
 
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
@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
 
Dernière édition:
Vote positif 0 Vote négatif

RyuAutodidacte

XLDnaute Impliqué
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é ?
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

C
  • Question
XL 2021 VBA - créer une boucle de calcul pour remplir un tableau à partir de 2 autres sur une même feuille
Réponses
7
Affichages
565
clineM
C
W
  • Résolu(e)
XL 2016 Ordonner une cellule ou un pavé de cellules contenant des chr(10)
Réponses
5
Affichages
534
Webperegrino
W
K
  • Résolu(e)
Microsoft 365 Incrémenter des valeurs présentées à l'horizontale dans une autre feuille en verticale
Réponses
4
Affichages
428
kikilabrax
K
L
  • Question
Microsoft 365 Tableau transposant des valeur B2 juxtaposant des valeurs au départ en A1
Réponses
2
Affichages
356
lusert
L
S
  • Question
Microsoft 365 VBA pour copier une une des données d'une ligne à une autre
Réponses
3
Affichages
625
salma_hayek
S
E
  • Résolu(e)
Microsoft 365 Problème d'organisation des colonnes dans une ListBox en VBA Excel
Réponses
2
Affichages
813
eCHO
E
T
  • Résolu(e)
Microsoft 365 Transformer les données d'une colonne en fonction de 2 autres colonnes
Réponses
5
Affichages
677
Tidjyphenom
T
C
  • Question
XL 2013 [VBA]Créer un nombre de ligne en fonction d'un certain nombre de colonne et remplir ces lignes avec certaines valeurs
Réponses
6
Affichages
816
CaptainSalt31
C
Z
  • Question
XL 2010 tableau pour comparer deux colonnes et écrire le résultat dans une troisième colonne
2
Réponses
28
Affichages
2 K
zephir94
Z
K
  • Question
Microsoft 365 Formule INDEX/EQUIV avec plusieurs valeurs pour une même en-tête
Réponses
2
Affichages
2 K
KLfy
K
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…