Sub QuickSortRec(ByRef Liste, ByVal iBas As Long, ByVal iHaut As Long)
'Quicksort recursif
'Liste est supposé être un tableau VBA (Array) à 2 dimensions (1 colonne)
Dim Pivot, Ech
Dim iMin As Long, iMax As Long
    If iHaut <= iBas Then Exit Sub
    iMin = iBas
    iMax = iHaut
    Pivot = Liste(iMax, 1)
    iBas = iMin - 1
    iHaut = iMin
    Do Until iHaut >= iMax
        If Liste(iHaut, 1) < Pivot Then
            iBas = iBas + 1
            If iHaut > iBas Then
                Ech = Liste(iHaut, 1)
                Liste(iHaut, 1) = Liste(iBas, 1)
                Liste(iBas, 1) = Ech
            End If
        End If
        iHaut = iHaut + 1
    Loop
    Liste(iMax, 1) = Liste(iBas + 1, 1)
    Liste(iBas + 1, 1) = Pivot
    If iBas > iMin Then QuickSortRec Liste, iMin, iBas
    If iBas + 2 < iMax Then QuickSortRec Liste, iBas + 2, iMax
End Sub

Sub QuickSortNonRec(ByRef Liste)
'Quicksort non recursif
'Liste est supposé être un tableau VBA (Array) à 2 dimensions (1 colonne)
Dim Pivot, Ech, ListeLimites() As Long, Lim As Long
Dim iHaut As Long, iBas As Long, iMin As Long, iMax As Long
    ReDim ListeLimites(1 To 2, 1 To 1)
    Lim = 1
    ListeLimites(1, Lim) = LBound(Liste, 1)
    ListeLimites(2, Lim) = UBound(Liste, 1)
    Do Until Lim > UBound(ListeLimites, 2)
        iMin = ListeLimites(1, Lim)
        iMax = ListeLimites(2, Lim)
        Pivot = Liste(iMax, 1)
        iBas = iMin - 1
        iHaut = iMin
        Do Until iHaut >= iMax
            If Liste(iHaut, 1) < Pivot Then
                iBas = iBas + 1
                If iHaut > iBas Then
                    Ech = Liste(iHaut, 1)
                    Liste(iHaut, 1) = Liste(iBas, 1)
                    Liste(iBas, 1) = Ech
                End If
            End If
            iHaut = iHaut + 1
        Loop
        Liste(iMax, 1) = Liste(iBas + 1, 1)
        Liste(iBas + 1, 1) = Pivot
        If iBas > iMin Then
            ReDim Preserve ListeLimites(1 To 2, 1 To UBound(ListeLimites, 2) + 1)
            ListeLimites(1, UBound(ListeLimites, 2)) = iMin
            ListeLimites(2, UBound(ListeLimites, 2)) = iBas
        End If
        If iBas + 2 < iMax Then
            ReDim Preserve ListeLimites(1 To 2, 1 To UBound(ListeLimites, 2) + 1)
            ListeLimites(1, UBound(ListeLimites, 2)) = iBas + 2
            ListeLimites(2, UBound(ListeLimites, 2)) = iMax
        End If
        Lim = Lim + 1
    Loop
End Sub

 
Sub EcritFicUTF8SansBOM(AdrFic As String)
    Dim UTFStream As Object, BinaryStream As Object, i As Long
    Const adTypeText = 2, adTypeBinary = 1
    Const adCR = 13, adLF = 10, adCRLF = -1
    Const adWriteChar = 0, adWriteLine = 1
    Const adSaveCreateNotExist = 1, adSaveCreateOverWrite = 2, adModeReadWrite = 3
 
    Set UTFStream = CreateObject("ADODB.Stream")
    UTFStream.Type = adTypeText
    UTFStream.Mode = adModeReadWrite
    UTFStream.Charset = "UTF-8"
    UTFStream.LineSeparator = adLF
    UTFStream.Open
    For i = 1 To UBound(TableauHTML, 1)
        If i < UBound(TableauHTML, 1) Then
            UTFStream.WriteText TableauHTML(i), adWriteLine
        Else
            UTFStream.WriteText TableauHTML(i), adWriteChar
        End If
    Next i
    UTFStream.Position = 3 'après le BOM
 
    Set BinaryStream = CreateObject("ADODB.Stream")
    BinaryStream.Type = adTypeBinary
    BinaryStream.Mode = adModeReadWrite
    BinaryStream.Open
 
    'Copie sans le BOM
    UTFStream.CopyTo BinaryStream
 
    UTFStream.Flush
    UTFStream.Close
 
    BinaryStream.SaveToFile AdrFic, adSaveCreateOverWrite
    BinaryStream.Flush
    BinaryStream.Close
    Set UTFStream = Nothing
    Set BinaryStream = Nothing
End Sub

Option Explicit
 
Public Enum TypeTri
    typeLibre = 0
    typeDate = 1
    typeNumeric = 2
    typeText = 3
    typeVide = 4
End Enum
 
sub Test()
    Dim tabData()           As Variant
    tabData= MonOnglet.Range("A1:D100").Value2
 
    ' Réalise un truc croissant sur la colonne D et décroissant sur la colonne A
    ' Les valeurs numériques sont triées en priorité (les autres sont mis à la suite)
    tabData= funcSortDatas(tabData, Array(4,-1), typeNumeric)
end sub
 
Function funcSortDatas(tabDatas() As Variant, tabOrder As Variant, Optional tTypeTri_1 As TypeTri = TypeTri.typeLibre _
                                                                , Optional tTypeTri_2 As TypeTri = TypeTri.typeLibre _
                                                                , Optional tTypeTri_3 As TypeTri = TypeTri.typeLibre _
                                                                , Optional tTypeTri_4 As TypeTri = TypeTri.typeLibre) As Variant
    Dim tabLignes()             As Variant
    Dim tabFinale()             As Variant
    Dim i                       As Long
    Dim j                       As Long
    Dim k                       As Long
    Dim intCar                  As Integer
    Dim dicoValues              As Object
    Dim strKey                  As String
    Dim strFormat               As String
    Dim strTri                  As String
 
    ReDim tabLignes(LBound(tabDatas, 1) To UBound(tabDatas, 1), 1 To 2)                                     ' Clé - Ligne TabDatas
    ReDim tabFinale(LBound(tabDatas, 1) To UBound(tabDatas, 1), LBound(tabDatas, 2) To UBound(tabDatas, 2)) ' Pour le rendu final
 
    ' On sauvegarde les lignes
    For i = LBound(tabLignes, 1) To UBound(tabLignes, 1)
        tabLignes(i, 2) = i
    Next
 
    ' 1 - Alimentation d'un dictionnaire
    Set dicoValues = CreateObject("Scripting.Dictionary")
 
    For j = LBound(tabOrder, 1) To UBound(tabOrder, 1)
        If Abs(tabOrder(j)) >= LBound(tabDatas, 2) And Abs(tabOrder(j)) <= UBound(tabDatas, 2) Then
            ' Ordre des tris appliqués
            strTri = ""
            Select Case tTypeTri_1
                Case TypeTri.typeDate: strTri = strTri & "D"
                Case TypeTri.typeNumeric: strTri = strTri & "N"
                Case TypeTri.typeText: strTri = strTri & "T"
                Case TypeTri.typeVide: strTri = strTri & "V"
            End Select
            Select Case tTypeTri_2
                Case TypeTri.typeDate: strTri = strTri & "D"
                Case TypeTri.typeNumeric: strTri = strTri & "N"
                Case TypeTri.typeText: strTri = strTri & "T"
                Case TypeTri.typeVide: strTri = strTri & "V"
            End Select
            Select Case tTypeTri_3
                Case TypeTri.typeDate: strTri = strTri & "D"
                Case TypeTri.typeNumeric: strTri = strTri & "N"
                Case TypeTri.typeText: strTri = strTri & "T"
                Case TypeTri.typeVide: strTri = strTri & "V"
            End Select
            Select Case tTypeTri_4
                Case TypeTri.typeDate: strTri = strTri & "D"
                Case TypeTri.typeNumeric: strTri = strTri & "N"
                Case TypeTri.typeText: strTri = strTri & "T"
                Case TypeTri.typeVide: strTri = strTri & "V"
            End Select
            ' On finalise l'ordre d'affichage
            If UCase(strTri) Like UCase("N") = False Then strTri = strTri & "N"
            If UCase(strTri) Like UCase("D") = False Then strTri = strTri & "D"
            If UCase(strTri) Like UCase("V") = False Then strTri = strTri & "V"
            If UCase(strTri) Like UCase("T") = False Then strTri = strTri & "T"
 
            If Len(strTri) > 0 Then
                For intCar = 1 To Len(strTri)
                    dicoValues.RemoveAll
 
                    Select Case UCase(Mid(strTri, intCar, 1))
                        Case UCase("D") ' Date
                            For i = LBound(tabDatas, 1) To UBound(tabDatas, 1)
                                If Len(tabDatas(i, Abs(tabOrder(j)))) > 0 Then
                                    If IsDate(tabDatas(i, Abs(tabOrder(j)))) Then
                                        strKey = UCase("A" & tabDatas(i, Abs(tabOrder(j))))
                                        If Not dicoValues.exists(strKey) Then dicoValues.Add strKey, 0
                                    End If
                                End If
                            Next
                        Case UCase("N") ' Numérique
                            For i = LBound(tabDatas, 1) To UBound(tabDatas, 1)
                                If Len(tabDatas(i, Abs(tabOrder(j)))) > 0 Then
                                    If Not IsDate(tabDatas(i, Abs(tabOrder(j)))) And IsNumeric(tabDatas(i, Abs(tabOrder(j)))) Then
                                        strKey = UCase("A" & tabDatas(i, Abs(tabOrder(j))))
                                        If Not dicoValues.exists(strKey) Then dicoValues.Add strKey, 0
                                    End If
                                End If
                            Next
                        Case UCase("T") ' Texte
                            For i = LBound(tabDatas, 1) To UBound(tabDatas, 1)
                                If Len(tabDatas(i, Abs(tabOrder(j)))) > 0 Then
                                    If Not IsDate(tabDatas(i, Abs(tabOrder(j)))) And Not IsNumeric(tabDatas(i, Abs(tabOrder(j)))) Then
                                        strKey = UCase("A" & tabDatas(i, Abs(tabOrder(j))))
                                        If Not dicoValues.exists(strKey) Then dicoValues.Add strKey, 0
                                    End If
                                End If
                            Next
                        Case UCase("V")
                            For i = LBound(tabDatas, 1) To UBound(tabDatas, 1)
                                If Len(tabDatas(i, Abs(tabOrder(j)))) = 0 Then
                                    strKey = UCase("A" & tabDatas(i, Abs(tabOrder(j))))
                                    If Not dicoValues.exists(strKey) Then dicoValues.Add strKey, 0
 
                                    Exit For    ' On ne peut avoir qu'un seul vide
                                End If
                            Next
                    End Select
 
 
                    If dicoValues.Count > 0 Then
                        ' Tri du jeu de données
                        Set dicoValues = DicoTri(dicoValues, "A", Abs(tabOrder(j)) = tabOrder(j))
 
                        ' Format de la clé pour cette colonne, pour aligner tout le monde au même nombre de caractères
                        strFormat = ""
                        For k = 1 To Len(dicoValues.Count)
                            strFormat = strFormat & "0"
                        Next
 
                        ' On attribue une valeur numérique formatée
                        ' intCar est présent pour trier en fonction de la priorité que l'on donne aux données (Date, texte, numérique)
                        For i = LBound(tabDatas, 1) To UBound(tabDatas, 1)
                            strKey = UCase("A" & tabDatas(i, Abs(tabOrder(j))))
                            If dicoValues.exists(strKey) Then
                                If Len(tabLignes(i, 1)) > 0 Then tabLignes(i, 1) = tabLignes(i, 1) & "_"
                                tabLignes(i, 1) = tabLignes(i, 1) & intCar & Format(dicoValues(strKey), strFormat)
                            End If
                        Next
                    End If
                Next
            End If
        End If
    Next
 
 
    ' Tri des données
    tri2D tabLignes, LBound(tabLignes, 1), UBound(tabLignes, 1)
 
    ' Reprise des données sources, organisées en fonction du tri "naturel"
    For i = LBound(tabLignes, 1) To UBound(tabLignes, 1)
        For j = LBound(tabFinale, 2) To UBound(tabFinale, 2)
            tabFinale(i, j) = tabDatas(tabLignes(i, 2), j)
        Next
    Next
 
    ' Affichage/restitution des données
    funcSortDatas = tabFinale
 
End Function
 
Function DicoTri(Dico, strKey As String, Optional bCroissant As Boolean = True) As Object
    Dim tbl() As Variant
    Dim i       As Long
    Dim strTest As String
 
    tbl = Dico.keys                         ' Transfert Dictionnaire dans Array
    For i = LBound(tbl, 1) To UBound(tbl, 1)
        tbl(i) = Right(tbl(i), Len(tbl(i)) - Len(strKey))
        If Len(tbl(i)) > 0 Then
 
 
            If IsDate(tbl(i)) Then
                strTest = Empty
                On Error Resume Next
                strTest = CDbl(tbl(i))
                On Error GoTo 0
 
                If Len(strTest) > 0 Then
                    If CDbl(tbl(i)) <> CDate(tbl(i)) Then
                        tbl(i) = CDbl(tbl(i))
                    Else
                        tbl(i) = CDate(tbl(i))
                    End If
                End If
            ElseIf IsNumeric(tbl(i)) Then
                tbl(i) = CDbl(tbl(i))
            End If
        End If
    Next
 
    tri tbl, LBound(tbl), UBound(tbl)       ' Tri Array
    Dico.RemoveAll                          ' Création du dictionnaire
 
    Select Case bCroissant
        Case True
            For i = LBound(tbl) To UBound(tbl)
                Dico(UCase("A" & tbl(i))) = i                   ' Pour l'ordre d'affichage
            Next i
 
        Case False
            For i = LBound(tbl) To UBound(tbl)
                Dico(UCase("A" & tbl(i))) = UBound(tbl) - i     ' Pour l'ordre d'affichage
            Next i
 
    End Select
 
    Set DicoTri = Dico
End Function
 
Sub tri(a, gauc As Long, droi As Long) ' Quick sort
    Dim Ref         As Variant
    Dim g           As Long
    Dim d           As Long
    Dim temp        As Variant
 
    Ref = a((gauc + droi) \ 2)
    g = gauc: d = droi
    Do
        Do While a(g) < Ref: g = g + 1: Loop
        Do While Ref < a(d): d = d - 1: Loop
        If g <= d Then
            temp = a(g): a(g) = a(d): a(d) = temp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a, g, droi)
    If gauc < d Then Call tri(a, gauc, d)
End Sub
 
Sub tri2D(a, gauc, droi) ' Quick sort
    Dim Ref         As Variant
    Dim g           As Long
    Dim d           As Long
    Dim temp        As Variant
 
    Ref = a((gauc + droi) \ 2, 1)
    g = gauc: d = droi
    Do
        Do While a(g, 1) < Ref: g = g + 1: Loop
        Do While Ref < a(d, 1): d = d - 1: Loop
        If g <= d Then
            temp = a(g, 1): a(g, 1) = a(d, 1): a(d, 1) = temp
            temp = a(g, 2): a(g, 2) = a(d, 2): a(d, 2) = temp
            g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri2D(a, g, droi)
    If gauc < d Then Call tri2D(a, gauc, d)
End Sub