VBA Mélanger les caractères d'une chaîne

Liminaire

Le but de l'astuce est d'apprendre à mélanger n'importe quel array.
L'exercice choisit est de mélanger les lettres d'un mot et d'en obtenir un "score". Le score étant le nombre de lettres qui restent en place à la fin du mélange.

Code d'appel

Option Explicit

Sub Melange()
Dim W, S() As Long
Dim A$, C&, i As Integer
Dim B As Byte, Bo As Boolean, L As Byte

    W = Array("a", "abracadabra", "seesaw", "elk", "grrrrrr", "up", "azerty", "tttt")
    For B = 0 To UBound(W)
        C = 0
        Select Case Len(W(B))
            Case 1: L = 1
            Case Else
                i = NbLettresDiff(W(B))
                If i >= Len(W(B)) \ 2 Then
                    L = 0
                ElseIf i = 1 Then
                    L = Len(W(B))
                Else
                    L = Len(W(B)) - i
                End If
        End Select
Recommence:
        Do
            S() = MelangeIndicesTab(Len(W(B)))
            Bo = BonMelange(S, L)
        Loop While Not Bo
        A = MelangeLeMot(CStr(W(B)), S)
        C = Verifie(W(B), A)
        If C > L Then GoTo Recommence
        Debug.Print W(B) & " ==> " & A & " (Score : " & C & ")"
    Next
End Sub

Les fonctions utilisées

Mélange les indices d'un tableau

Cette fonction créée une variable tableau, de type Long, contenant des indices mélangés.
Exemple : MelangeIndicesTab(3) peut me sortir :
MelangeIndicesTab(0) = 2
MelangeIndicesTab(1) = 1
MelangeIndicesTab(2) = 3
MelangeIndicesTab(3) = 0

Function MelangeIndicesTab(L As Long) As Long()
Dim i As Integer, j As Integer, temp() As Long
Dim C As New Collection

    ReDim temp(L - 1)
    If L = 1 Then
        temp(0) = 0
    ElseIf L = 2 Then
        temp(0) = 1: temp(1) = 0
    Else
        Randomize
        Do
            j = Int(Rnd * L)
            On Error Resume Next
            C.Add CStr(j), CStr(j)
            If Err <> 0 Then
                On Error GoTo 0
            Else
                temp(j) = i
                i = i + 1
            End If
        Loop While C.Count <> L
    End If
    MelangeIndicesTab = temp
End Function

Fonction de vérification du tableau

Cette fonction vérifie si la variable tableau créée précédemment est bien mélangée.

Function BonMelange(t() As Long, Lim As Byte) As Boolean
Dim i&, C&
    
    For i = LBound(t) To UBound(t)
        If t(i) = i Then C = C + 1
    Next i
    BonMelange = (C <= Lim)
End Function

Fonction de mélange des caractères

Function MelangeLeMot(W$, S() As Long) As String
Dim i&, temp, strR$

    temp = Split(StrConv(W, vbUnicode), Chr(0))
    For i = 0 To UBound(S)
        strR = strR & temp(S(i))
    Next i
    MelangeLeMot = strR
End Function

Nombre de lettres communes à deux chaînes

Function Verifie(W, A) As Integer
Dim i As Integer, L As Integer

    For i = 1 To Len(W)
        If Mid(W, i, 1) = Mid(A, i, 1) Then L = L + 1
    Next i
    Verifie = L
End Function

Nombre de lettres différentes dans une chaîne

Function NbLettresDiff(W) As Integer
Dim i&, C As New Collection
    For i = 1 To Len(W)
        On Error Resume Next
        C.Add Mid(W, i, 1), Mid(W, i, 1)
    Next i
    NbLettresDiff = C.Count
End Function