XL 2010 extraire les 2 meilleurs scores dans une plage de cellule et les recopier sur une autre feuille

Sub Classement()
    Dim elv As Range, l As Integer, c As Range, max As Integer, relai As Byte, Diff As String, TypVoie As String
    Dim max2 As Integer, relai2 As Byte, Diff2 As String, TypVoie2 As String
    Application.Calculation = xlManual
    Sheets("Evaluation").[B4:G26].ClearContents
    For Each elv In Sheets("Evaluation").[A4:A26]
        max = 0
        max2 = 0
        With Sheets("Global seances")
            For l = 6 To 27
                If elv = .Cells(l, 2) Then
                    For Each c In .Range(.Cells(l, 3), .Cells(l, 51))
                        If .Cells(l, c.Column()) <> "" And .Cells(4, c.Column()) > max Then
                            max2 = max
                                max = .Cells(4, c.Column())
                            relai2 = relai
                            relai = .Cells(2, c.Column())
                            Diff2 = Diff
                            Diff = .Cells(5, c.Column())
                            TypVoie2 = TypVoie
                            TypVoie = .Cells(3, c.Column())
                        End If
                    Next c
                    Range("B" & elv.Row()) = relai
                    Range("C" & elv.Row()) = Diff
                    Range("D" & elv.Row()) = TypVoie
                    Range("E" & elv.Row()) = relai2
                    Range("F" & elv.Row()) = Diff2
                    Range("G" & elv.Row()) = TypVoie2
                End If
            Next