VBA: como misturar os caracteres de uma cadeia

Última modificação: 19 de fevereiro de 2018 às 05:14 por Ana Spadari .

O objetivo desta dica é mostrar como misturar qualquer matriz. O exercício escolhido é misturar as letras de uma palavra e obter uma pontuação. A pontuação é o número de letras que permanece no lugar no final da mistura.

Código de chamada
Quais são as funções usadas

Código de chamada

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
Recomece:
        Do
            S() = MisturaíndicesTab(Len(W(B)))
            Bo = Boamistura(S, L)
        Loop While Not Bo
        A = MisturaAPalavra(CStr(W(B)), S)
        C = Verifique(W(B), A)
        If C > L Then GoTo Recomece
        Debug.Print W(B) & " ==> " & A & " (Score : " & C & ")"
    Next
End Sub

Quais são as funções usadas

Misturar os Índices de uma tabela

Esta função cria uma variável tabela, do tipo longo, contendo Índices misturados.
Exemplo: MisturaíncicesTab(3) pode me tirar:
MisturaíncicesTab(0) = 2
MisturaíncicesTab(1) = 1
MisturaíncicesTab(2) = 3
MisturaíncicesTab(3) = 0

Function MisturaíncicesTab(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
    MisturaíncicesTab= temp
End Function

Função de verificação da tabela

Esta função verifica se a varável tabela criada anteriormente foi bem misturada.

Function Boamistura(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
    Boamistura = (C <= Lim)
End Function

Função de mistura dos caracteres

Function MisturaAPalavra(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
    MisturaAPalavra = strR
End Function

Número de letras comuns às duas cadeias

Function Verifique(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
    Verifique = L
End Function

Número de letras diferentes em uma cadeia

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

Foto: © VBA.

Veja também

VBA: como misturar os caracteres de uma cadeia
Call vba - Dicas -Visual Basic
Vba pegar dados de outra planilha fechada - Dicas -Excel
Cores vba - Dicas -Visual Basic
Vba aguardar processamento - Dicas -Excel
Vba pesquisar valores e retornar dados - Dicas -Excel

Este documento, intitulado 'VBA: como misturar os caracteres de uma cadeia', está disponível sob a licença Creative Commons. Você pode copiar e/ou modificar o conteúdo desta página com base nas condições estipuladas pela licença. Não se esqueça de creditar o CCM (br.ccm.net) ao utilizar este artigo.