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

    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)

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

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

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