Comment trier les nombres en ordre décroissant qui sont attachés au texte dans une cellule

Je pense que le moyen le plus simple est de créer une colonne d'assistance où vous extrayez la valeur numérique. En supposant que vos données commencent dans A1, écrivez une formule dans la colonne B comme xxx

avec ceci, vous pouvez facilement trier les données.

Cela le fera pour vous.

Ajoutez le code ci-dessous dans un nouveau module dans VBA, puis appelez la formule dans une cellule adjacente à votre cellule avec les valeurs. p>

donc dans l'exemple Ci-dessous, vos valeurs d'origine sont dans la colonne A forte> et la personnalité UDF dans la colonne B forte> directement adjacente. p>

Public Function SortByInternalNumber(ByVal strText As String, ByVal strDelimiter As String)
    Dim arrValues() As String, strValue As String, i As Long, lngNumber As Long, arrNumbers() As String
    Dim strNumber As String, lngMaxNumber As Long, lngMaxIndex As Long, strResult As String
    Dim bFound As Boolean, arrMaxValues() As Long, lngIndex As Long, strMaxValue As String
    Dim strThisValue As String

    Application.Volatile

    ' Split up the initial string with all of the values.
    arrValues = Split(strText, strDelimiter)

    For i = 0 To UBound(arrValues)
        strValue = Trim(arrValues(i))

        strNumber = Replace(Replace(Split(strValue, "[")(1), "%", ""), "]", "")

        ReDim Preserve arrNumbers(i)
        arrNumbers(i) = strNumber
    Next

    ' Now process all of the numbers in the descending order.
    Do While 1 = 1
        lngMaxNumber = -1
        bFound = False

        For i = 0 To UBound(arrNumbers)
            If arrNumbers(i) <> "" Then
                lngNumber = CLng(arrNumbers(i))

                If lngMaxNumber < lngNumber Then
                    lngMaxNumber = lngNumber
                    lngMaxIndex = i
                End If

                bFound = True
            End If
        Next

        If Not bFound Then Exit Do
        lngIndex = -1

        ' Retrieve all of the values that are of the same value as the current max.
        For i = 0 To UBound(arrNumbers)
            If arrNumbers(i) <> "" Then
                If CLng(arrNumbers(i)) = lngMaxNumber Then
                    lngIndex = lngIndex + 1
                    ReDim Preserve arrMaxValues(lngIndex)
                    arrMaxValues(lngIndex) = i
                End If
            End If
        Next

        strMaxValue = ""

        ' Now do the same thing as above but instead of descending, do ascending.
        For i = 0 To UBound(arrMaxValues)
            strThisValue = Trim(arrValues(arrMaxValues(i)))

            If strMaxValue > strThisValue Or strMaxValue = "" Then
                strMaxValue = strThisValue
                lngMaxIndex = arrMaxValues(i)
            End If
        Next

        strResult = strResult & ", " & strMaxValue 
        arrNumbers(lngMaxIndex) = ""
    Loop

    If strResult <> "" Then
        strResult = Mid(strResult, 3)
    End If

    SortByInternalNumber = Trim(strResult)
End Function

peut essayer une autre alternative

Sub testsort()
Dim txt As String, txt2 As String, Arr As Variant
Dim Nums() As Long, NumSort() As Long, i As Integer, k As Integer


txt = "CSI [40%], CSSEl [50%], LDN [10%], ABC [40%],ZXH[30%]"
Arr = Split(txt, ",")
ReDim Nums(LBound(Arr) To UBound(Arr))
ReDim NumSort(LBound(Arr) To UBound(Arr))
    For i = LBound(Arr) To UBound(Arr)
    Spos = InStr(1, Arr(i), "[")
    Epos = InStr(1, Arr(i), "%")
       If Spos > 0 And Epos > Spos Then
       Nums(i) = Val(Mid(Arr(i), Spos + 1, Epos - Spos - 1))
       Else
       Nums(i) = 0
       End If
    Next i


    For i = LBound(Arr) To UBound(Arr)
    NumSort(i) = LBound(Arr)
        For k = LBound(Arr) To UBound(Arr)
            If Nums(i) < Nums(k) Or (Nums(i) = Nums(k) And k < i) Then
            NumSort(i) = NumSort(i) + 1
            End If
        Next
    Debug.Print Arr(i), Nums(i), NumSort(i)
    Next


    For i = LBound(Arr) To UBound(Arr)  ' rank
    For k = LBound(Arr) To UBound(Arr)
    If NumSort(k) = i Then
    txt2 = txt2 & Arr(k) & ","
    Exit For
    End If
    Next k
    Next i

    If Len(txt2) > 0 Then txt2 = Left(txt2, Len(txt2) - 1) 'delete last comma
    Debug.Print txt2
End Sub