Avoir autant de ligne dans chaque colonne

Bonjour j'aurais besoin d'aide pour organiser mes donnés je shouaite avoir autant de ligne remplis dans chaque colonne.

les donné sont classer par ordre croissant est je voudrais qu'il le reste.

j'ai joint 2 fichiers

un avec des colonnes de longueur différente (comme mon fichier actuel) et un avec des longueur égal (résultat que je voudrais avoir).

merci pour votre aide

cedric93 a écrit :

Bonjour j'aurais besoin d'aide pour organiser mes donnés je souhaite avoir autant de lignes remplies dans chaque colonne.

les données sont classées par ordre croissant et je voudrais qu'elles le restent.

j'ai joint 2 fichiers

un avec des colonnes de longueurs différentes(comme mon fichier actuel) et un avec des longueurs égales (résultat que je voudrais avoir).

merci pour votre aide

bonjour,

une proposition

Sub test()
    j = 1
    i = 1
    While Cells(1, j) <> ""
        dlj = Cells(Rows.Count, j).End(xlUp).Row
        If j > 1 Then
            Range(Cells(1, j), Cells(dlj, j)).Copy Cells(i, 1)
            Columns(j).Clear
        End If
        i = i + dlj
        j = j + 1
    Wend
    i = i - 1
    j = j - 1
    ne = i / j
    If ne <> Int(ne) Then ne = Int(ne) + 1
    For k = 1 To j
        Cells((k - 1) * ne + 1, 1).Range(Cells(1, 1), Cells(ne, 1)).Copy Cells(1, k)
    Next k
    Range(Cells(ne + 1, 1), Cells(i, 1)).Clear
End Sub

bonjour merci pour votre aide sa fonctionne mais il y a un petit problème, mon fichier a des colonnes de A à AB pour un total de

1 586 770 cellules.

je suis donc obligé de lancer la macro sur une première moitier (de A à R puis sur la seconde de S à AB) mais cela me fait un décalage entre les cellules de A:R et celle de S:AB.

est ce qu'il y aurait une solution pour exécuter la macro sur la totalité sans que cela produise une erreur.

merci

Bonjour,

une nouvelle version avec une autre logique

Sub atester()
    Dim t, a As Variant
    nc = ActiveSheet.UsedRange.Columns.Count
    nce = ActiveSheet.UsedRange.Count
    Application.ScreenUpdating = False
    i = 0
    ReDim t(1 To nce)
    For j = 1 To nc

        dl = Cells(Rows.Count, j).End(xlUp).Row
        a = Range(Cells(1, j), Cells(dl, j))
        For k = LBound(a, 1) To UBound(a, 1)
            i = i + 1
            t(i) = a(k, 1)
        Next k
        Erase a
    Next j
    Cells.Delete
    ne = Int(i / nc)
    If ne <> i / nc Then ne = ne + 1
    i = 0
    ReDim a(1 To ne, 1 To 1)
    For j = 1 To nc
        For k = 1 To ne
            i = i + 1
            a(k, 1) = t(i)
        Next k
        Cells(1, j).Resize(ne, 1) = a
    Next j
    Application.ScreenUpdating = True
End Sub

bonjour je viens de tester la macro elle fonctionne mais il y a un petit problème les cellules colorées perde leurs couleurs après utilisation de la macro.

serait il possible de leurs faire garder leurs couleurs merci

cedric93 a écrit :

bonjour je viens de tester la macro elle fonctionne mais il y a un petit problème les cellules colorées perdent leur couleur après utilisation de la macro.

serait-il possible de leur faire garder leur couleur ? merci

bonjour,

code adapté mais beaucoup plus lent !!!!

Sub atester()
    Dim t, a As Variant, c() As Long
    nc = ActiveSheet.UsedRange.Columns.Count
    nce = ActiveSheet.UsedRange.Count
    Application.ScreenUpdating = False
    i = 0
    ReDim t(1 To nce)
    ReDim c(1 To nce)
    For j = 1 To nc

        dl = Cells(Rows.Count, j).End(xlUp).Row
        a = Range(Cells(1, j), Cells(dl, j))
        For k = LBound(a, 1) To UBound(a, 1)
            i = i + 1
            t(i) = a(k, 1)
            c(i) = Cells(k, j).Interior.Color
        Next k
        Erase a
    Next j
    Cells.Delete
    ne = Int(i / nc)
    If ne <> i / nc Then ne = ne + 1
    i = 0
    ReDim a(1 To ne, 1 To 1)
    For j = 1 To nc
        For k = 1 To ne
            i = i + 1
            a(k, 1) = t(i)
            Cells(k, j).Interior.Color = c(i)
        Next k
        Cells(1, j).Resize(ne, 1) = a
    Next j
    Application.ScreenUpdating = True
End Sub

bonsoir j'ai testé la macro elle fonctionne parfaitement

merci