XL 2016 transposer des lignes en colonnes Excel 2016

BOBbrao

XLDnaute Nouveau
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
1602333019200.png
 

Pièces jointes

  • Test_10102020.xlsx
    372.6 KB · Affichages: 24

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @BOBbrao,

Un essai en VBA. Le code est dans le module attaché à la feuille "test" (prévoir #0,5 s)
VB:
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)
VB:
   .Range(.Range("a1"), .Cells(der, "b")).Sort key1:=Range("a1"), order1:=xlAscending, _
         key2:=Range("b1"), order2:=xlAscending, Header:=xlYes, MatchCase:=False
 

Pièces jointes

  • BOBbrao- Test_10102020- v1.xlsm
    382.3 KB · Affichages: 15
Dernière édition:

youky(BJ)

XLDnaute Barbatruc
Bonjour tous,
Bonjour mapomme suis en retard pourtant avec une macro très courte.
Prévoir 5 secondes
Bruno
VB:
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
 

Pièces jointes

  • Test_10102020.xlsm
    377.5 KB · Affichages: 19

klin89

XLDnaute Accro
Bonjour à tous, :)

Une autre façon de procéder :
VB:
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
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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".
 

Pièces jointes

  • BOBbrao- Test_10102020- v2.xlsm
    382 KB · Affichages: 27
Dernière édition:

Discussions similaires