Consolidation colonnes multiples via lignes supplémentaires

Bonjour la communauté,

Je cherche une solution efficace pour un problème très bête de retraitement de données sur Excel.

Le cas : J'ai un export sorti d'un CRM qui est très mal foutu puisqu'il s'agit d'une table d'historique de "statuts de deal" mais qu'elle est consolidée de façon à avoir 1 ligne = 1 deal et les statuts et dates associées apparaissent en colonnes à côté (le nombre de colonnes dépendant du deal qui a eu le plus de changements de statuts).

J'aurai donc besoin de trouver une méthode efficace pour retraiter ce type d'export et obtenir une table d'historique plus classique avec un deal id qui peut se répéter. J'obtiens sans problème le résultat souhaité avec une série de copier coller puis une suppression des doublons mais l'objectif est de rendre ce retraitement plus "automatique / simple" et si possible ne s'alourdissant pas si certaines lignes venaient à avoir des historiques plus longs.

Je vous met en PJ un fichier avec l'export actuel et le résultat cible souhaité.

Merci à toute bonne âme qui voudra se pencher sur mon cas et me proposer des solutions, quelle qu'elles soient.

PS : Désolé pour le titre je savais pas trop comment décrire le problème (et j'ai pas réussi à trouver quelque chose de similaire non plus sur le forum, faute d'avoir les bons mots-clés sans doute).

Bonsoir Nico_P

A tester :

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
    a = Sheets("Actuel").[a1].CurrentRegion.Value
    ReDim b(1 To ((UBound(a, 1) - 1) * (UBound(a, 2) - 2) / 2) + 1, 1 To 4)
    n = 1
    b(n, 1) = a(1, 1): b(n, 2) = a(1, 2)
    b(n, 3) = a(1, 3): b(n, 4) = a(1, 4)
    For j = 3 To UBound(a, 2) Step 2
        For i = 2 To UBound(a, 1)
            n = n + 1
            b(n, 1) = a(i, 1)
            b(n, 2) = a(i, 2)
            b(n, 3) = a(i, j)
            b(n, 4) = a(i, j + 1)
        Next
    Next
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Résultat Cible").Cells(1)
        .CurrentRegion.Clear
        With .Resize(UBound(b, 1), UBound(b, 2))
            .FormulaLocal = b
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci Klin89 pour ta proposition, je teste demain et je te fais un retour. Bonne fin de soirée.

Merci beaucoup pour ton aide Klin89. J'ai pu tester la macro ce matin et je peux confirmer qu'elle fonctionnait bien (y compris en ajoutant des colonnes supplémentaires).

Il y avait une différence avec mon résultat cible c'est qu'il manquait la suppression des doublons mais j'ai réussi à la rajouter moi même sans problème. Voilà la macro complétée si jamais quelqu'un a le même cas :

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
    a = Sheets("Actuel").[a1].CurrentRegion.Value
    ReDim b(1 To ((UBound(a, 1) - 1) * (UBound(a, 2) - 2) / 2) + 1, 1 To 4)
    n = 1
    b(n, 1) = a(1, 1): b(n, 2) = a(1, 2)
    b(n, 3) = a(1, 3): b(n, 4) = a(1, 4)
    For j = 3 To UBound(a, 2) Step 2
        For i = 2 To UBound(a, 1)
            n = n + 1
            b(n, 1) = a(i, 1)
            b(n, 2) = a(i, 2)
            b(n, 3) = a(i, j)
            b(n, 4) = a(i, j + 1)
        Next
    Next
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Résultat Cible").Cells(1)
        .CurrentRegion.Clear
        With .Resize(UBound(b, 1), UBound(b, 2))
            .FormulaLocal = b
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
        'Supp_doublons
    Sheets("Résultat Cible").Select
    Columns("A:D").Select
    ActiveSheet.Range("$A:$D").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlYes
End Sub

En revanche il y a un petit point auquel je n'avais pas fait attention dans mon fichier exemple qui pourrait être amélioré c'est que là il conserve 1 ligne par deal avec statut & date vide. Est-ce qu'il y aurait moyen de ne pas conserver les lignes sans date au moment de l'exécution ? J'ai essayé de comprendre ta macro mais elle est un peu trop poussée pour moi ^^. Si cela complexifie trop c'est pas très grave cela me va déjà très bien comme ça, c'est juste de l'optimisation.

Merci pour ton aide en tout cas.

re Nico_P

Le code réajusté, j'ai rajouté une condition.

Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
    a = Sheets("Actuel").[a1].CurrentRegion.Value
    ReDim b(1 To ((UBound(a, 1) - 1) * (UBound(a, 2) - 2) / 2) + 1, 1 To 4)
    n = 1
    b(n, 1) = a(1, 1): b(n, 2) = a(1, 2)
    b(n, 3) = a(1, 3): b(n, 4) = a(1, 4)
    For j = 3 To UBound(a, 2) Step 2
        For i = 2 To UBound(a, 1)
            'If Not IsEmpty(a(i, j )) Then
            If Not IsEmpty(a(i, j + 1)) Then
                n = n + 1
                b(n, 1) = a(i, 1)
                b(n, 2) = a(i, 2)
                b(n, 3) = a(i, j)
                b(n, 4) = a(i, j + 1)
            End If
        Next
    Next
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Résultat Cible").Cells(1)
        .CurrentRegion.Clear
        With .Resize(n, UBound(b, 2))
            .FormulaLocal = b
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci beaucoup Klin89, ça marche nickel. Bonne soirée