Function SortCharacters(theString As String) As String
Dim currentChar As String
Dim sourceNum As Integer
Dim destNum As Integer
For sourceNum = 1 To Len(theString)
currentChar = Mid(theString, sourceNum, 1)
If sourceNum = 1 Then
SortCharacters = currentChar
Else
destNum = 1
While destNum <= Len(SortCharacters) And currentChar > Mid(SortCharacters, destNum, 1)
destNum = destNum + 1
Wend
SortCharacters = Left(SortCharacters, destNum - 1) & currentChar & Mid(SortCharacters, destNum)
End If
Next sourceNum
End Function
=SortCharacters(A1)
la même avec option de triBonjour le fil
Glané dans mes archives de mai 2003
Une fonction VBA personnalisée (dont la paternité n'est pas mienne)
Option Compare Text
Function SortString(ByVal iRange, Optional Croissant As Boolean = True)
'Trevor Shuttleworth, mpep, modifié fs, mpfe
Dim i%, j%, sTemp$
For j = 1 To Len(iRange) - 1
For i = 1 To Len(iRange) - 1
If Mid(iRange, i, 1) > Mid(iRange, i + 1, 1) Then
sTemp = Mid(iRange, i, 1)
Mid(iRange, i, 1) = Mid(iRange, i + 1, 1)
Mid(iRange, i + 1, 1) = sTemp
End If
Next
Next
If Croissant = False Then
For i = Len(iRange) To 1 Step -1
SortString = SortString & Mid(iRange, i, 1)
Next
Exit Function
End If
SortString = iRange
End Function
Function SortCharacters(theString As String) As String
Dim currentChar As String
Dim sourceNum As Integer
Dim destNum As Integer
For sourceNum = 1 To Len(theString)
currentChar = Mid(theString, sourceNum, 1)
If sourceNum = 1 Then
SortCharacters = currentChar
Else
destNum = 1
While destNum <= Len(SortCharacters) And UCase(currentChar) > UCase(Mid(SortCharacters, destNum, 1))
destNum = destNum + 1
Wend
SortCharacters = Left(SortCharacters, destNum - 1) & currentChar & Mid(SortCharacters, destNum)
End If
Next sourceNum
End Function
Public Function TriAlphaCell(ByVal parmString As String) As String
Dim lngBuckets(0 To 65535) As Long, lngLoop&, bChar&
For lngLoop = 1 To Len(parmString)
bChar = AscW(Mid(parmString, lngLoop, 1))
lngBuckets(bChar) = lngBuckets(bChar) + 1
Next
TriAlphaCell = vbNullString
For lngLoop = LBound(lngBuckets) To UBound(lngBuckets)
If lngBuckets(lngLoop) <> 0 Then
TriAlphaCell = TriAlphaCell & String(lngBuckets(lngLoop), ChrW(lngLoop))
End If
Next
'auteur: aikimark, issue de : CollatedCharsUnicode
End Function
Function SortString(ByVal iRange, Optional Croissant As Boolean = True)
Dim i%, j%, S%, sTemp$, tabl
tabl = Split(iRange, " ")
For S = 0 To UBound(tabl)
For j = 1 To Len(tabl(S)) - 1
For i = 1 To Len(tabl(S)) - 1
If Mid(tabl(S), i, 1) > Mid(tabl(S), i + 1, 1) Then
sTemp = Mid(tabl(S), i, 1)
Mid(tabl(S), i, 1) = Mid(tabl(S), i + 1, 1)
Mid(tabl(S), i + 1, 1) = sTemp
End If
Next
Next
Next
If Croissant = False Then
For i = Len(tabl(S)) To 1 Step -1
SortString = SortString & Mid(tabl(S), i, 1)
Next
Exit Function
End If
For S = 0 To UBound(tabl)
Text = Text + tabl(S) + " "
Next
SortString = Text
End Function