Regrouper si cellule identique dans une colonne

Bonjour

Je suis nouveau et j'ai besoin d'un petit coup de main .

J'essaye d'adapter le code de Klin89 a mon fichier mais je n'y arrive pas ...

Je souhaiterais faire un regroupement des valeurs identiques de la colonne F faire la somme des colonnes H,I,J,P transposer la colonne A ( date ) en ligne a partir de la colonne R avec un trie et que dans chaque cellule j'ai l'écart et la valeur .Pas très clair j'ai donc déposé un fichier avec deux onglets avec le tableau original et le résultat attendu et quelques explications .Les fichiers peuvent atteindre facilement 200 000 lignes .Merci de votre aide

Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, t As Long, dico1 As Object, dico2 As Object
    Set dico1 = CreateObject("Scripting.Dictionary")
    dico1.CompareMode = 1
    Set dico2 = CreateObject("Scripting.Dictionary")
    With Sheets("SOURCE").Range("a1").CurrentRegion
        a = .Value: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
        b(1, 1) = "N°": b(1, 2) = "Référence": b(1, 3) = "date"
        n = 1: t = 3
        For i = 2 To UBound(a, 1)
            If Not dico1.exists(a(i, 2)) Then
                t = t + 1
                dico1(a(i, 2)) = t
                If UBound(b, 2) < t Then
                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 10)
                End If
                b(1, t) = a(i, 2)
            End If
            If Not dico2.exists(a(i, 1)) Then
                n = n + 1
                dico2(a(i, 1)) = n
                b(n, 1) = n - 1
                b(n, 2) = a(i, 1)
                b(n, 3) = a(i, 3)
            End If
            b(dico2(a(i, 1)), dico1(a(i, 2))) = b(dico2(a(i, 1)), dico1(a(i, 2))) + a(i, 4)
        Next
    End With
    Application.ScreenUpdating = False
    'restitution et mise en forme
    With Sheets("Feuil1").Range("a1")
        .CurrentRegion.Clear
        With .Resize(n, t)
            .Value = b
            .Cells(1, .Columns.Count + 1).Value = "Total"
            .Cells(2, .Columns.Count + 1).Resize(.Rows.Count - 1).Formula = "=sum(rc[-" & .Columns.Count - 3 & "]:rc[-1])"
            With .CurrentRegion
                .Font.Name = "calibri"
                .Font.Size = 10
                .VerticalAlignment = xlCenter
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .HorizontalAlignment = xlCenter
                    With .Resize(, 3)
                        .Interior.ColorIndex = 40
                    End With
                    With .Offset(, 3).Resize(, .Columns.Count - 4)
                        .Interior.ColorIndex = 44
                    End With
                    .Cells(.Columns.Count).Interior.ColorIndex = 45
                End With
                With .Columns(1)
                    .Resize(, 3).HorizontalAlignment = xlCenter
                    With .Offset(1).Resize(.Rows.Count - 1)
                        .Interior.ColorIndex = 36
                    End With
                End With
            End With
        End With
        Set dico1 = Nothing: Set dico2 = Nothing
    End With
    Application.ScreenUpdating = True
End Sub

Ci dessous le code de klin89 que je voudrais adapter à mon fichier. Merci pour l'aide ...

Bonjour surferdort,

Vois ceci :

Au préalable, crée la Feuil1

Option Explicit
Sub test()
    Dim a, b, i As Long, n As Long, AL As Object, dico As Object
    Set AL = CreateObject("System.Collections.ArrayList")
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Fichier original").Range("a7").CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            If Not AL.Contains(a(i, 1)) Then AL.Add a(i, 1)
        Next
        AL.Sort: n = 1
        For i = 2 To UBound(a, 2)
            AL.Insert i - 2, a(1, i)
        Next
        ReDim b(1 To UBound(a, 1), 1 To AL.Count)
        For i = 0 To AL.Count - 1
            b(n, i + 1) = AL(i)
        Next
        For i = 2 To UBound(a, 1)
            If Not dico.exists(a(i, 6)) Then
                n = n + 1: dico(a(i, 6)) = n
                b(n, 1) = a(i, 2): b(n, 2) = a(i, 3)
                b(n, 3) = a(i, 4): b(n, 4) = a(i, 5)
                b(n, 5) = a(i, 6): b(n, 6) = a(i, 7)
                b(n, 10) = a(i, 11): b(n, 11) = a(i, 12)
                b(n, 12) = a(i, 13): b(n, 13) = a(i, 14)
                b(n, 14) = a(i, 15): b(n, 16) = a(i, 17)
            End If
            b(dico(a(i, 6)), 7) = b(dico(a(i, 6)), 7) + a(i, 8)
            b(dico(a(i, 6)), 9) = b(dico(a(i, 6)), 9) + a(i, 10)
            b(dico(a(i, 6)), 15) = b(dico(a(i, 6)), 15) + a(i, 16)
            b(dico(a(i, 6)), AL.IndexOf(a(i, 1), 0) + 1) = "E " & a(i, 9) & " | " & "V " & a(i, 16)
        Next
        For i = 2 To n
            b(i, 8) = b(i, 9) - b(i, 7)
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("a1")
        .CurrentRegion.Clear
        With .Resize(n, UBound(b, 2))
            .Value = b
            .Columns.AutoFit
            .Font.Name = "calibri"
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
            End With
        End With
    End With
    Set AL = Nothing: Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Au vu de ce que tu présentes, 200 000 lignes représente 200 000 colonnes une fois transposé, ça va pas le faire.

klin89

Bonjour

Merci beaucoup Klin 89 je reconnais que tu assures ...

Le code il est nickel c'est ce que je voulais, pour 178000 lignes il a fallut que quelques secondes donc très rapide.

Par contre je n'ai pas tout compris si tu pouvais me le décrypter ce serait super sympa ( sans abuser ) car je souhaite progresser. Dans tous les cas merci encore .