Scinder une variable tableau en blocs de 5 éléments et les transposer

[cibleo]

Bonsoir le forum

Dans le code ci-dessous, la variable tableau (A) est transposée en ligne.
Voir ce que j'obtiens en Feuil1 ainsi que le résultat souhaité : transposer par blocs de 5 cellules.

'renvoi les données
    Feuil1.Cells(i + 2, "D").Offset(, 1).Resize(, UBound(A)) = Application.Transpose(Application.Transpose(A))

Sub Transposer()
  Application.ScreenUpdating = False
  Set dico = CreateObject("Scripting.Dictionary")
  For Each c In Feuil1.Range("A2:A" & Feuil1.Range("A" & Rows.Count).End(xlUp).Row)
    temp = c.Value
    dico(temp) = dico(temp) & c.Offset(, 1) & ";"
  Next c
  B = dico.keys
  For i = LBound(B) To UBound(B)
    Feuil1.Cells(i + 2, "D") = B(i)
    A = Split(dico.Item(B(i)), ";")
    'renvoi les données
    Feuil1.Cells(i + 2, "D").Offset(, 1).Resize(, UBound(A)) = Application.Transpose(Application.Transpose(A))
  Next i
  Feuil1.Range("D1") = "Pointures"
  Feuil1.Range("E1") = "Noms"
Application.ScreenUpdating = True
End Sub

En Feuil2, dans un autre exemple, je parviens à transposer par blocs de 5 avec la macro ci-dessous (trouvé sur le net) :

Sub Transposer_par_5()
    sq = Feuil2.Range("A2:A25")
    sn = Cells(1, 20).Resize(UBound(sq) \ 5 + 1, 5)
    For j = 1 To UBound(sq)
        sn((j - 1) \ 5 + 1, (j - 1) Mod 5 + 1) = sq(j, 1)
    Next
    Feuil2.Cells(2, 3).Resize(UBound(sq) \ 5 + 1, 5) = sn
    Feuil2.Cells(1, 3) = "Noms"
End Sub

Je ne parviens pas à l'adapter dans mon 1er code, à l'appliquer sur la variable (A)
(Si possible en gardant la structure du 1er code).

Pouvez-vous m'aider, Cibleo

 

[david84]

Re : Scinder une variable tableau en blocs de 5 éléments et les transposer

Bonsoir,
une possibilité :

Sub Transposer()
  Application.ScreenUpdating = False
  Set dico = CreateObject("Scripting.Dictionary")
  With Feuil1
    .Range("D1") = "Pointures"
    .Range("E1") = "Noms"
    
    For Each c In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
        dico(c.Value) = dico(c.Value) & c.Offset(, 1) & ";"
    Next c
    B = dico.keys
    For i = LBound(B) To UBound(B)
        A = Split(dico.Item(B(i)), ";")
        'renvoi les données
        Dim T()
        ReDim T(0 To Int((UBound(A)) / 5), 0 To 5)
        For j = 0 To Int((UBound(A)) / 5)
            T(j, 0) = B(i)
            For k = 1 To 5
                T(j, k) = A(n): n = n + 1
                If n = UBound(A) Then Exit For
            Next k
        Next j
        n = 0
        DerLig = .Range("D" & .Rows.Count).End(xlUp).Row + 1
        .Cells(DerLig, "D").Resize(UBound(T) + 1, UBound(T, 2) + 1) = T
    Next i
End With
Application.ScreenUpdating = True
End Sub

A+

 

[klin89]

Re : Scinder une variable tableau en blocs de 5 éléments et les transposer

Bonsoir à tous,
Bonsoir david84, cibleo

A tester :

Sub Transposer1()
  Application.ScreenUpdating = False
  Set dico = CreateObject("Scripting.Dictionary")
  With Feuil1
    .Range("D1") = "Pointures"
    .Range("E1") = "Noms"
    For Each c In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
        dico(c.Value) = dico(c.Value) & c.Offset(, 1) & ";"
    Next c
    B = dico.keys
    DerLig = 2
    For i = LBound(B) To UBound(B)
        A = Split(dico.Item(B(i)), ";")
        'renvoie les données
        Dim T()
        ReDim T(1 To UBound(A), 1 To 1)
        For j = 0 To UBound(A) - 1
            T(j + 1, 1) = A(j)
        Next j
        If UBound(T) Mod 5 = 0 Then
          NbreBloc = UBound(T) \ 5
        Else
          NbreBloc = UBound(T) \ 5 + 1
        End If
        Dim Tablo()
        ReDim Tablo(1 To NbreBloc, 1 To 5)
        For j = 1 To UBound(T)
          Tablo((j - 1) \ 5 + 1, (j - 1) Mod 5 + 1) = T(j, 1)
        Next
        .Cells(DerLig, "E").Resize(NbreBloc, 5) = Tablo
        .Cells(DerLig, "D").Resize(NbreBloc, 1) = B(i)
        DerLig = .Range("D" & .Rows.Count).End(xlUp).Row + 1
    Next i
End With
Application.ScreenUpdating = True
End Sub

Klin89

 

[cibleo]

Re : Scinder une variable tableau en blocs de 5 éléments et les transposer

Bonsoir David, klin89

J'ai bien examiné les 2 codes pas à pas.
j'obtiens bien ce que je souhaitais.

Je vous remercie tous les 2.

Au plaisir Cibleo