Trier des donnée: 1 colonne en plusieurs colonnes

Salut à toutes et tous!

Je reviens vers vous car je sais que vous avez toujours la solution même aux pries problèmes ^^

Je viens d'effectuer une recherche et en ai ressortis un paquet d'infos.

Mon problème et que toute ces infos sont dans une seul colonne:

Nom |

Tel |

Fax |

Nom |

Tel |

Fax |

Nom |

Tel |

Fax |

et j'aimerai que ce soit comme ça :

Nom | Tel | Fax

Nom | Tel | Fax

Nom | Tel | Fax

Je peux toujours mettre un excel en PJ si c'est pas claire

Merci d'avance vous me sauveriez la vie !!!

PS: pas besoin de me parler du collage spécial (transposer) car j'ai plus de 1000 lignes ^^

Bonjour et bienvenue sur le forum

Un essai à tester. Te convient-il ?

Bye !

bonjour,

solution via une formule (qui suppose que les données sont en colonne A) à mettre par exemple en colonne C à tirer vers la droite 2 x et à tirer vers le bas autant de fois que nécessaire.

=INDIRECT("A" & (LIGNE(A1)-1)*3+COLONNE(A1))

Merci pour la réponse,

elle marche mais partiellement car parfois il y a 8 informations parfois 9.

Cette variable fait buger la formule qui décale ainsi tout.

Pourrait-on modifier la formule pour quelle prenne en compte cette variable?

Regarder mon fichier

Bonsoir Supermoquette, h2so4, gmb, le forum

En supposant que les cellules en tëte de ligne (et seulement celles-ci) soient toujours sous le format suivant : Verdana et taille 12

Dans un module standard :

Sub Transpose()
Dim Rng As Areas, i As Long
    Application.ScreenUpdating = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Offset(, 1)
        .Formula = "=if(Leformat(a1),1,"""")"
        .Value = .Value
        On Error Resume Next
        .SpecialCells(2, 1).EntireRow.Insert
        .EntireColumn.Delete
    End With
    Set Rng = Columns(1).SpecialCells(2).Areas
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub
    For i = 1 To Rng.Count
        Rng(i).Copy
        Cells(i, 3).PasteSpecial Transpose:=True
    Next
    Columns.AutoFit
    Columns("A:B").Delete
    Application.ScreenUpdating = True
End Sub

Function Leformat(r As Range) As Boolean
    Leformat = r.Font.Name = "Verdana" And r.Font.Size = 12
End Function

klin89

Merci Klin89 mais il me transpose tout sur une même ligne :/ Pourtant j'ai bien copié collé le code.

tu pourrai me le mettre sur un excel en pj?

Sub Transpose()
Dim Rng As Areas, i As Long
    Application.ScreenUpdating = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Offset(, 1)
        .Formula = "=if(Leformat(a1),1,"""")"
        .Value = .Value
        On Error Resume Next
        .SpecialCells(2, 1).EntireRow.Insert
        .EntireColumn.Delete
    End With
    Set Rng = Columns(1).SpecialCells(2).Areas
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub
    For i = 1 To Rng.Count
        Rng(i).Copy
        Cells(i, 3).PasteSpecial Transpose:=True
    Next
    Columns.AutoFit
    Columns("A:B").Delete
    Application.ScreenUpdating = True
End Sub

Function Leformat(r As Range) As Boolean
    Leformat = r.Font.Name = "Verdana" And r.Font.Size = 12
End Function

Re Supermoquette,

Je viens de découvrir un truc, la taille de la police est de 11,9 et non pas 12

Tu peux tester dans la fenêtre Exécution :

?activecell.Font.Size

11,9

Le code comme ceci

Sub Transpose()
Dim Rng As Areas, i As Long
    Application.ScreenUpdating = False
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Offset(, 1)
        .Formula = "=if(Leformat(a1),1,"""")"
        .Value = .Value
        On Error Resume Next
        .SpecialCells(2, 1).EntireRow.Insert
        .EntireColumn.Delete
    End With
    Set Rng = Columns(1).SpecialCells(2).Areas
    On Error GoTo 0
    If Rng Is Nothing Then Exit Sub
    For i = 1 To Rng.Count
        Rng(i).Copy
        Cells(i, 3).PasteSpecial Transpose:=True
    Next
    Columns.ColumnWidth = 100
    Columns.AutoFit
    Columns("A:B").Delete
    Application.ScreenUpdating = True
End Sub

Function Leformat(r As Range) As Boolean
    Leformat = r.Font.Name = "Verdana" And r.Font.Size = 11.9
End Function

klin89

Super, ça marche nickel!!!

Merci beaucoup!!!