XL 2013 Code pour résumer des données et les coller dans une autre feuille

Sub macro1()
    Application.ScreenUpdating = False
    Dim c As Range, f As Worksheet, d As Object
    Set d = CreateObject("scripting.dictionary")
    d.comparemode = 1
    Set f = Feuil3
    f.Activate
    With f
        .Rows("1:" & .Columns(1).Find("Old", lookat:=xlPart).Row - 1).Delete shift:=xlUp
        For Each c In .Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp).Address)
            If c.Value Like "Reg" & "*" Then
                c = Mid(c, 5) * 1
            End If
            c.Offset(, 2) = Mid(c.Offset(, 2), 2) * 1
        Next
        f.UsedRange.Sort key1:=Columns(3), order1:=1, key2:=Columns(1), order2:=1, Header:=xlYes

        For a = 2 To .UsedRange.Rows.Count
            If Not d.exists(.Cells(a, 3).Value) Then
                d.Item(.Cells(a, 3).Value) = ""
            Else
                If Not d.Item(.Cells(a, 3).Value) Like "*" & .Cells(a, 1) & "*" Then
                    d.Item(.Cells(a, 3).Value) = d.Item(.Cells(a, 3).Value) & "/" & .Cells(a, 1)

                End If
            End If
        Next

        With .Cells(1, 5).Resize(, d.Count)
            .Value = d.keys
            .Font.Bold = True
        End With
        .Cells(2, 5).Resize(, d.Count) = d.items
        For a = 5 To .Cells(1, Columns.Count).End(xlToLeft).Column
            b = Split(.Cells(2, a), "/")
            For e = 3 To UBound(b) + 3
                .Cells(e, a) = b(e - 3)
            Next e
            Range(.Cells(2, a), .Cells(3, a)).Delete shift:=xlUp
        Next a
        .Cells(1, 5).CurrentRegion.Copy Sheets("New").Range("f10")
    End With
    Sheets("New").Activate

    Set d = Nothing
    Set f = Nothing
End Sub

.Cells(1, 5).CurrentRegion.Copy Sheets("New").Range("f10")

        Next a
        .Cells(1, 5).CurrentRegion.Copy 'Sheets("New").Range("f10")
    End With
    Sheets("New").Activate
        Range("f10").PasteSpecial Paste:=xlValues
    Set d = Nothing
    Set f = Nothing
End Sub