XL 2016 transposer des lignes en colonnes Excel 2016

[BOBbrao]

Bonjour à tous,
Dans le fichier joint je cherche à transposer un tableau de +/-26000 lignes et 2 colonnes en un tableau de +/-1900 colonnes de 1 à 118 lignes.
Ma difficulté (j'y suis depuis vendredi ap-midi) est que je n'arrive pas à convertir l'exemple ci-dessous, autrement qu'à la main : que le code service 00001 soit converti en 1 seule colonne 00001 contenant les différents axes (et ainsi de suite code service 00005 jusqu'au 1900ème code service.
Actuellement j'ai commencé toujours en manuel mais j'ai plusieurs axes à traiter dans des volumes identiques et devrai le faire plusieurs fois dans l'année.
Si vous avez une solution reproductible en Excel eh bien grand merci

 

[mapomme]

Bonjour @BOBbrao,

Un essai en VBA. Le code est dans le module attaché à la feuille "test" (prévoir #0,5 s)

Sub ventiler()
Dim dico, der&, t, i&, max&, j&, nlig&, nco&, s, x, y
With Sheets("test")
   Application.ScreenUpdating = False
   Set dico = CreateObject("scripting.dictionary"): dico.CompareMode = TextCompare
   If .FilterMode Then .ShowAllData
   der = .Cells(Rows.Count, "a").End(xlUp).Row
   .Range(.Range("a1"), .Cells(der, "b")).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False
   t = .Range(.Range("a1"), .Cells(der, "b"))
   For i = 2 To UBound(t)
      dico(CStr(t(i, 1))) = dico(CStr(t(i, 1))) & "/" & t(i, 2)
   Next i
   For Each x In dico.Items
      j = Len(x) - Len(Replace(x, "/", ""))
      If j > max Then max = j
   Next x
   Erase t
   ReDim t(1 To max + 1, 1 To dico.Count)
   For Each x In dico.Keys
      nlig = 1: nco = nco + 1: t(nlig, nco) = x: s = Split(Mid(dico(x), 2), "/")
      For j = 0 To UBound(s)
         nlig = nlig + 1
         t(nlig, nco) = s(j)
      Next j
   Next x
   .Range("e1").CurrentRegion.Clear
   .Range("e1").Resize(UBound(t), UBound(t, 2)).NumberFormat = "@"
   .Range("e1").Resize(UBound(t), UBound(t, 2)) = t
   .Range("e1").CurrentRegion.Borders.LineStyle = xlContinuous
   .Range("e1").CurrentRegion.Rows(1).Font.Bold = True
   .Range("e1").CurrentRegion.Rows(1).Font.Color = RGB(0, 0, 255)
End With
End Sub

edit : l'instruction ci-dessous est complètement inutile (scorie d'une autre tentative)

   .Range(.Range("a1"), .Cells(der, "b")).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False

 

[youky(BJ)]

Bonjour tous,
Bonjour mapomme suis en retard pourtant avec une macro très courte.
Prévoir 5 secondes
Bruno

Sub mycode()
Application.ScreenUpdating = False
[E1:XFD1000].Clear
For k = 2 To [A65000].End(3).Row
cs = Cells(k, 1)
col = Application.Match(cs, [E1:XFD1], 0)
If IsNumeric(col) Then
bas = Cells(65000, col + 4).End(3).Row + 1
Cells(bas, col + 4) = Cells(k, 2)
Else
col = Application.CountA([E1:XFD1]) + 5
Cells(1, col) = Cells(k, 1)
Cells(2, col) = Cells(k, 2)
End If
Next
Application.ScreenUpdating = True
End Sub

 

[mapomme]

Bonjour @youky(BJ)

 

[klin89]

Bonjour à tous,

Une autre façon de procéder :

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, t As Long, maxRow As Long, dico as object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("test").Range("a1").CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 1)
            For i = 2 To UBound(a, 1)
                If Not dico.exists(a(i, 1)) Then
                    t = t + 1
                    If t > UBound(b, 2) Then
                        ReDim Preserve b(1 To UBound(b, 1), 1 To t)
                    End If
                    b(1, t) = a(i, 1)
                    dico(a(i, 1)) = Array(1, t)
                End If
                w = dico(a(i, 1))
                w(0) = w(0) + 1
                b(w(0), w(1)) = a(i, 2)
                maxRow = Application.Max(maxRow, w(0))
                dico(a(i, 1)) = w
            Next
        .Offset(, .Columns.Count + 1).Resize(maxRow, UBound(b, 2)).Value = b
    End With
Set dico = nothing
End Sub

klin89

 

[chris]

Bonjour à tous

Une solution PowerQuery, intégré à Excel

 

[mapomme]

Re,

Pour nos amis MACistes qui ne disposent pas de la bibliothèque "Scripting.dictionary" (et donc pas de dictionary), une version VBA très rapide voire plus rapide que la version avec dictionary.
Prévoir #0,4 sec.

Le code est toujours dans le module de la feuille "test".

 

[Amilo]

Bonjour à tous,

Une autre proposition avec Power query pour le fun,

Cordialement

 

[BOBbrao]

Merci beaucoup cela fonctionne
Et je viens de découvrir qu'il existe Discussions similaires à droite de mon écran : le VBA étant pour moi d'un niveau +++ je vais aussi creuser via des formules Excel.
Bonne journée

 

[chris]

Bonjour

Sur un tel volume les formules vont ramer à mort

La solution PowerQuery est simple...

 

[BOBbrao]

merci à tous je clos.