Réorganiser une base de donnée

Bonjour à tous,

Je dispose d'une base de donnée comprenant toute une liste d'informations : Compte, Nom client, date d'ouverture, rôle sur le compte, raison d'ouverture....

Etant donnée que plusieurs personnes se touvent sur un compte avec différents rôles, cela me crée donc plusieurs lignes pour un seul et même numéro de compte.

Mon objectif final est d'avoir une seule ligne par compte et d'ajouter des colonnes pour les informations nom client, date d'ouverture etc... le nombre de ligne par compte peut varier de 1 a 10.

Vous trouverez ci-joint un fichier avec 2 onglets, le premier étant la situation de base et le second l'objectif que je souhaite atteindre.

Merci d'avance et bonne et heureuse année en avance.

Bonjour,

Il manque des critéres de sélection.

exp : pourquoi Michael Chaise est rangé dans nom2 ?

Un exemple de tri par tcd

Bonjour,

Merci pour la réponse.

En quoi manque t il des critères de sélection ?

Il est dans nom2 car il serait la 2eme personne associé sur le compte.

En gros j'aimerais que pour chaque compte, il y est une seule et unique ligne dans Excel.

Si plusieurs personnes sont présente sur un compte, je préfère créer de nouvelles colonnes.

Est-il possible de faire ça à travers VBA ? J'ai plusieurs milliers de ligne malheureusement.

Merci pour votre temps.

Bonjour,

Essaie ainsi :

Sub ReorgComptes()
    Dim d As Object, k, cpt, n%, i%, j%
    Set d = CreateObject("Scripting.Dictionary")
    With Worksheets("Base")
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To n
            k = .Cells(i, 1)
            For j = 2 To 5
                cpt = cpt & ";" & .Cells(i, j).Value2
            Next j
            If d.exists(k) Then
                cpt = d(k) & cpt: d(k) = cpt
            Else
                d(k) = cpt
            End If
            cpt = ""
        Next i
    End With
    n = 1
    With Worksheets("Objectif")
        For Each k In d.keys
            cpt = Split(d(k), ";"): cpt(0) = k
            n = n + 1: .Range("A" & n).Resize(, UBound(cpt) + 1).Value = cpt
            For i = 3 To UBound(cpt) Step 4
                .Cells(n, i) = Val(.Cells(n, i))
            Next i
        Next k
        .Activate
    End With
End Sub

Codialement et bonne fin d'année.

Salut Djidji, bonne fin d'année.

Bonjour le fil

Un poil différent :

Restitution en Feuil1

Option Explicit
Sub Regroupement()
Dim a, i As Long, j As Long, n As Long, col As Byte, w()
    a = Sheets("Base").Cells(1).CurrentRegion.Value
    n = 1: col = UBound(a, 2)
    For j = 1 To col
        a(n, j) = a(n, j) & "_1"
    Next
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = VBA.Array(n, col)
                For j = 1 To col
                    a(n, j) = a(i, j)
                Next
            Else
                w = .Item(a(i, 1)): w(1) = w(1) + col
                If UBound(a, 2) < w(1) Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To w(1))
                End If
                For j = 1 To col
                    a(w(0), w(1) - col + j) = a(i, j)
                Next
                .Item(a(i, 1)) = w
            End If
        Next
    End With
    'restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1)
        .CurrentRegion.Clear
        With .Resize(n, UBound(a, 2))
            .Value = a
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            With .Rows(1)
                .Font.Size = 11
                .Interior.ColorIndex = 44
                .BorderAround Weight:=xlThin
            End With
            If UBound(a, 2) > 5 Then
                With .Resize(1, 5)
                    .AutoFill .Resize(, UBound(a, 2))
                End With
            End If
             .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Bonne fin d'année à tous

klin89

Bonsoir à tous,

J'ai enfin pu mettre la main sur un ordinateur et testé les macros ! Vos deux macros fonctionne parfaitement.

Je vais choisir la 2ème car avec les tests que j'ai effectué, elle est dynamique si d'autres colonnes devaient se rajouter.

Merci pour votre travail et excellent début d'année !