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

Novembre 2017



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

Publié par pijaku.
Ce document intitulé «  VBA Mélanger les caractères d'une chaîne  » issu de CommentCaMarche (www.commentcamarche.net) est mis à disposition sous les termes de la licence Creative Commons. Vous pouvez copier, modifier des copies de cette page, dans les conditions fixées par la licence, tant que cette note apparaît clairement.