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
Cet article est régulièrement mis à jour par des experts sous la direction de Jean-François Pillou, fondateur de CommentCaMarche et directeur délégué au développement numérique du groupe Figaro.
