Données sur plusieurs lignes à mettre sur une seule

Bonjour,

J'ai un tableau avec des adresses et des résidents, parfois 1 résidents, parfois plusieurs.

Quand il y en a plusieurs, j'ai de nombreuses lignes pour une même adresse.

Je souhaiterais garder une ligne par adresse et que les résidents se copient sur les colonnes suivantes.

Merci de vos conseils.

Stéphane

Ci joint un exemple de mon fichier

bonjour,

une proposition via une macro (travailler sur une copie du classeur) la macro modifie le tableau original

Sub aargh()
    With Sheets("feuil1")
        dl = .Cells(1, 1).End(xlDown).Row
        .Range("A1:C" & dl).Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes
        i = 2
        pa = ""
        While .Cells(i, 1) <> ""
            If .Cells(i, 1) <> pa Then
                k = 2
                pa = .Cells(i, 1)
                i = i + 1
            Else
                k = k + 2
                If k > maxk Then maxk = k
                .Cells(i, 2).Resize(, 2).Copy .Cells(i - 1, k)
                Rows(i).Delete shift:=xlUp
            End If
        Wend
        .Cells(1, 2).Resize(, 2).Copy .Cells(1, 2).Resize(, maxk)
    End With
End Sub

Bonjour, Salut h2so4 !

Sub RecompTbl()
    Dim d As Object, Tbl(), k, itm, i%, n%, j%, a%
    Set d = CreateObject("Scripting.Dictionary")
    With Worksheets("Feuil1")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = .Cells(i, 1)
            If d.exists(k) Then
                itm = d(k) & ";" & .Cells(i, 2) & ";" & .Cells(i, 3)
                d(k) = itm
            Else
                itm = .Cells(i, 2) & ";" & .Cells(i, 3)
                d(k) = itm
            End If
        Next i
    End With
    a = d.Count: j = 2: n = 0: ReDim Tbl(a, j)
    For Each k In d.keys
        itm = Split(d(k), ";"): n = n + 1
        If UBound(itm) > j Then
            j = UBound(itm) + 1: ReDim Preserve Tbl(a, j)
        End If
        Tbl(n, 0) = k
        For i = 0 To UBound(itm)
            Tbl(n, i + 1) = itm(i)
        Next i
    Next k
    Tbl(0, 0) = "adresse"
    For i = 2 To j Step 2
        Tbl(0, i - 1) = "prénom résident " & i / 2
        Tbl(0, i) = "nom résident " & i / 2
    Next i
    With Worksheets.Add(after:=Worksheets("Feuil1"))
        With .Range("A1").Resize(a + 1, j + 1)
            .Value = Tbl
            .Borders.Weight = xlThin
            With .Rows(1)
                .HorizontalAlignment = xlCenter
                .Font.Bold = True
            End With
            .Columns.AutoFit
        End With
        .Activate
    End With
End Sub

Cordialement.

Bonjour à tous

Ma modeste proposition...

Bye !

Merci à tous les 3, les macros fonctionnent parfaitement bien.

Stéphane