Autres Classement colonnes en VBA

Option Explicit
Dim Sht As Worksheet
Dim Tab_Temp
Dim lgn As Long, L As Long, x As Long, DerLgn As Long
Sub Test()
 Set Sht = ThisWorkbook.Sheets("Feuil1")
x = 0
With Sht.Range("A1")
Tab_Temp = .Resize(.CurrentRegion.Rows.Count, .CurrentRegion.Columns.Count + 1).Value
End With
For lgn = 3 To UBound(Tab_Temp, 1)
   For L = 3 To UBound(Tab_Temp, 1)
      If Tab_Temp(L, 4) = Tab_Temp(lgn, 1) Then
        x = x + 1
          Sht.Cells(L, UBound(Tab_Temp, 2)) = lgn
            Exit For
      End If
   Next L
Next
DerLgn = Sht.Cells(Sht.Rows.Count, 6).End(xlUp).Row
With Sht.Sort
        .SortFields.Clear
        ' Ajouter la colonne 7 comme critère de tri
        .SortFields.Add Key:=Sht.Range("G3:G" & DerLgn), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        ' Appliquer le tri aux colonnes 4 à 7
        .SetRange Sht.Range("D2:G" & DerLgn)
        .Header = xlYes ' Si a une ligne d'en-tête
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sht.Columns(7).ClearContents
End Sub

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.CountA(Columns(4)) + 1
Application.ScreenUpdating = False
For n = 3 To derlig - 1
    i = Application.Match(Cells(n, 4), Columns(1), 0)
    If IsError(i) Then
        Cells(n, 4).Resize(, 3).Cut
        Cells(derlig, 4).Insert xlDown
    ElseIf i <> n Then
        Cells(n, 4).Resize(, 3).Cut
        Cells(i, 4).Insert xlDown
    End If
Next
End Sub

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
For n = 3 To derlig - 1
    If Cells(n, 4) <> "" Then
        i = Application.Match(Cells(n, 4), Columns(1), 0)
        If IsError(i) Then
            Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
            derlig = derlig + 1
        ElseIf i <> n Then
            Cells(n, 4).Resize(, 3).Cut
            Cells(i, 4).Insert xlDown
        End If
    End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
    If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub

Sub Classement()
Dim derlig&, n&, i As Variant
derlig = Application.Max(Application.CountA(Columns(1)), Application.CountA(Columns(4))) + 1
Application.ScreenUpdating = False
Doublons Range("A3:C" & derlig - 1), 3
Doublons Range("D3:F" & derlig - 1), 3
For n = 3 To derlig - 1
    If Cells(n, 4) <> "" Then
        i = Application.Match(Cells(n, 4), Columns(1), 0)
        If IsError(i) Then
            Cells(n, 4).Resize(, 3).Cut Cells(derlig, 4) 'couper-coller
            derlig = derlig + 1
        ElseIf i <> n Then
            Cells(n, 4).Resize(, 3).Cut
            Cells(i, 4).Insert xlDown
        End If
    End If
Next
'---supprime les lignes entièrement vides---
For n = derlig - 1 To 3 Step -1
    If Application.CountA(Rows(n)) = 0 Then Rows(n).Delete
Next
End Sub

Sub Doublons(plage As Range, col%)
Dim d As Object, i&, x$
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To plage.Rows.Count
    x = plage(i, 1)
    If x <> "" Then
        If d.exists(x) Then
            plage(d(x), col) = plage(d(x), col) + plage(i, col)
        Else
            d(x) = i 'mémorise la ligne
        End If
    End If
Next
plage.RemoveDuplicates 1, Header:=xlNo 'supprime les lignes en doublon
End Sub