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
Ce document intitulé « VBA Mélanger les caractères d'une chaîne » issu de Comment Ça Marche (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.