Saberexcel - site das macros
Essas macros e funções do Aplicativo Microsoft Excel VBA, analisa uma letra e faz interações de permutas entre as letras da palavras, e faz todas as interações possíveis entre elas. baixe o exemplo de planilha no final da página


Option Explicit
Option Base 1

Dim OriginalWord$, WordLength%, YesICanSpell As Boolean
Dim PermutCount&, SpellingTime!
Dim CharArray(), CharCounts()
Dim WordArray(), BuildArray()

Sub DynamicWordPermut()
Dim i&, j%, CharIndex%
Dim Reply As Boolean, Exists As Boolean
Dim CheckExistingWords%
Dim FoundArray(), Available()
Dim AvailCount%, AvailIndex%
Dim CaseCount%, CaseIndex%
Dim BuildCount&, BuildIndex&
Dim TargetCell As Range, StatusIndex&
Dim StatusStep&, StatusThreshold&
Dim StatusCount&, Hits%

With Application
.StatusBar = "Inicializando........"
'Checando a velocidade
SpellingTime = SpellingTimer
'recalcular os paramentros para dbPermuta
PermutationCalc
.StatusBar = False
'Show dialog
With ThisWorkbook.Sheets("dbPermuta")
With .CheckBoxes("cbExisting")
If Not (YesICanSpell) Then
.Value = xlOff
.Enabled = False
Else
.Enabled = True
End If
End With
Reply = .Show
If Not Reply Then Exit Sub
CheckExistingWords = .CheckBoxes("cbExisting").Value
End With
Workbooks.Add (xlWorksheet)
'CreateArrays trabalhando com arrays
CreateArrays
AvailCount = WordLength
BuildCount = 1
StatusCount = 0
'Calcula necessário para o número de interações
'(informações na statbusbar)
For CharIndex = 1 To UBound(CharArray)
BuildCount = BuildCount * .Fact(AvailCount) / (.Fact(CharCounts(CharIndex)) * .Fact(AvailCount - CharCounts(CharIndex)))
StatusCount = StatusCount + BuildCount
AvailCount = AvailCount - CharCounts(CharIndex)
Next
StatusStep = StatusCount / 100
StatusThreshold = 0
StatusIndex = 1

'variaveis de inicialização
BuildCount = 1
ReDim BuildArray(1)
'From the start the word is a string of asterisks
BuildArray(1) = .Rept("*", WordLength)
AvailCount = WordLength
For CharIndex = 1 To UBound(CharArray)
ReDim WordArray(BuildCount)
For BuildIndex = 1 To BuildCount
WordArray(BuildIndex) = BuildArray(BuildIndex)
Next
ReDim Available(AvailCount)
CaseCount = CharCounts(CharIndex)
'Calculate permutations of next character in available positions
'and multiply by permutations already built
BuildCount = .Fact(AvailCount) / (.Fact(CaseCount) * .Fact(AvailCount - CaseCount)) * UBound(WordArray)
ReDim BuildArray(BuildCount)
BuildIndex = 0
ReDim FoundArray(CaseCount)
For i = 1 To UBound(WordArray)
AvailIndex = 0
'Build array of available positions
For j = 1 To WordLength
If Mid(WordArray(i), j, 1) = "*" Then
AvailIndex = AvailIndex + 1
Available(AvailIndex) = j
End If
Next
'Set starting indices
For AvailIndex = 1 To CaseCount
If AvailIndex < CaseCount Then
FoundArray(AvailIndex) = AvailIndex
Else
FoundArray(AvailIndex) = AvailIndex - 1
End If
Next
Do 'Find all permutations of characters in available positions
CaseIndex = CaseCount
Do While FoundArray(CaseIndex) = (AvailCount - CaseCount + CaseIndex)
CaseIndex = CaseIndex - 1
Loop
FoundArray(CaseIndex) = FoundArray(CaseIndex) + 1
For CaseIndex = CaseIndex + 1 To CaseCount
FoundArray(CaseIndex) = FoundArray(CaseIndex - 1) + 1
Next
BuildIndex = BuildIndex + 1
'Use the word and replace the chosen positions with
'current characters
BuildArray(BuildIndex) = WordArray(i)
For CaseIndex = 1 To CaseCount
Mid(BuildArray(BuildIndex), Available(FoundArray(CaseIndex))) = CharArray(CharIndex)
Next
'Inform the user about the progress
If StatusIndex >= StatusThreshold Then
.StatusBar = "Building array " & CStr(Int(StatusIndex / StatusCount * 100)) & "%"
StatusThreshold = StatusThreshold + StatusStep
End If
StatusIndex = StatusIndex + 1
'Break when all characters have moved over to the other side
Loop While FoundArray(1) < (AvailCount - CaseCount + 1)
Next
'Reduce available positions with the number of
'characters the ones just used
AvailCount = AvailCount - CaseCount
Next
If CheckExistingWords = xlOn Then 'Check for existing words
Set TargetCell = ActiveSheet.Range("A1")
StatusStep = BuildCount / 100
StatusThreshold = 0
Hits = 0
For BuildIndex = 1 To BuildCount
Exists = .CheckSpelling(BuildArray(BuildIndex), , False)
If Exists Then
TargetCell.Value = BuildArray(BuildIndex)
Set TargetCell = TargetCell.Offset(1, 0)
Hits = Hits + 1
End If
If BuildIndex >= StatusThreshold Then
.StatusBar = "Checking words " & CStr(Int(BuildIndex / PermutCount * 100)) & "%"
StatusThreshold = StatusThreshold + StatusStep
End If
Next
If Hits = 0 Then TargetCell.Value = "Palavra nao encontrada"
Else 'Blast the array in chunks to the worksheet
BlastManager BuildArray, ActiveSheet.Range("A1:A" & BuildCount)
End If
.StatusBar = False
End With
End Sub

Sub PermutationCalc()
Dim i%, Pos%, Occurencies%
Dim EstimatedTime!, TimeUnit$
With ThisWorkbook.Sheets("dbPermuta")
OriginalWord = .EditBoxes("ebOriginalWord").Text
WordLength = Len(OriginalWord)
'Calculate the number of permutations if all
'characters are different
PermutCount = Application.Fact(WordLength)
For i = 1 To Len(OriginalWord) - 1
'Divide by the remaining number of occurencies
'to the right of each character
Pos = i
Occurencies = 0
Do
Occurencies = Occurencies + 1
Pos = InStr(Pos + 1, OriginalWord, Mid(OriginalWord, i, 1))
Loop While Pos > 0
PermutCount = PermutCount / Occurencies
Next
.Labels("laPermutCount").Text = PermutCount
'Estimate time to spell-check and write to dialog box
'with appropriate time unit
EstimatedTime = PermutCount * SpellingTime
Select Case EstimatedTime
Case Is < 120
TimeUnit = " segundos"
Case 120 To (120 * 60)
EstimatedTime = EstimatedTime / 60
TimeUnit = " minutos"
Case (120# * 60 + 1) To (120# * 60 * 24)
EstimatedTime = EstimatedTime / (60 * 60)
TimeUnit = " horas"
Case Else
EstimatedTime = EstimatedTime / (60# * 60 * 24)
TimeUnit = " dias"
End Select
EstimatedTime = Int(EstimatedTime + 0.5)
With .Labels("laEstimatedTime")
If YesICanSpell Then
.Text = CStr(EstimatedTime) & TimeUnit
Else
.Text = "Spelling not available"
End If
End With
'Dim OK button if sheet would be overflooded
.Buttons("buOK").Enabled = (PermutCount <= 2 ^ 16) Or .CheckBoxes("cbExisting") = xlOn
End With
End Sub

Sub CreateArrays()
Dim i%, j%, Pos%, UniqueString$
i = 1
j = 0
UniqueString = ""
Do While i <= Len(OriginalWord)
Pos = InStr(UniqueString, Mid(OriginalWord, i, 1))
If Pos = 0 Then 'This character is new, add to array
j = j + 1
ReDim Preserve CharArray(j)
ReDim Preserve CharCounts(j)
CharArray(j) = Mid(OriginalWord, i, 1)
UniqueString = UniqueString & CharArray(j)
CharCounts(j) = 1
Else 'This character exists already, increase its counter
CharCounts(Pos) = CharCounts(Pos) + 1
End If
i = i + 1
Loop
End Sub

Sub BlastManager(InArray, TheRange As Range)
Dim BlastArray(), Elements&
Dim i%, Size%, BlastOffset&
Const ChunkSize = 4095 'Largest chunk of cells that can be blasted
Elements = UBound(InArray)
BlastOffset = 0
With Application
Do 'This is self-explanatory, isn't it?
If Elements > ChunkSize Then
Size = ChunkSize
Else
Size = Elements
End If
ReDim BlastArray(Size)
For i = 1 To Size
BlastArray(i) = InArray(i + BlastOffset)
Next
SuperBlastArrayToSheet .Transpose(BlastArray), TheRange.Resize(Size, 1).Offset(BlastOffset, 0)
Elements = Elements - ChunkSize
BlastOffset = BlastOffset + ChunkSize
Loop While Elements > 0
End With
End Sub

Sub SuperBlastArrayToSheet(InArray, TheRange As Range)
With TheRange.Parent.Parent
.Names.Add Name:="wstempdata", RefersToR1C1:=InArray
TheRange.FormulaArray = "=wstempdata"
TheRange.Copy
TheRange.PasteSpecial Paste:=xlValues
.Names("wstempdata").Delete
End With
End Sub

Function SpellingTimer() As Single
Dim Time1#, Time2#, Time9#
Dim ElapsedTime#, Counter&, Exists As Boolean
Const PreSetTime = 1, MinCount = 1
Counter = 0
'Do it once just to clear the way
On Error GoTo SpellError
Exists = Application.CheckSpelling("infeasible", , False)
Time1 = Timer
Time9 = Time1 + PreSetTime
Do 'Do it a sufficient number of times
Exists = Application.CheckSpelling("infeasible", , False)
Time2 = Timer
Counter = Counter + 1
Loop Until (Time2 >= Time9) And (Counter > MinCount)
ElapsedTime = Time2 - Time1
SpellingTimer = ElapsedTime / Counter
YesICanSpell = True
Exit Function

SpellError:
YesICanSpell = False
SpellingTimer = 0
End Function



Aprenda tudo sobre o Aplicativo Microsoft Excel VBA







Compre eletronicos com segurança nas lojas SubMarino

Saberexcel - o site de quem precisa aprender macros Microsoft excel VBA

Esses macros do Aplicativo Microsoft Excel VBA, realizam interações de permuta entre caracteres de uma determinada palavra digitada em uma inputbox(Entrada de dados) na coluna (A), na folha de planilha. Mostra também o número de interações realizadas a palavra escolhida e o número de caracteres, esse valor retorna em uma célula na folha de planilha principal

Dim LinhaCorrente

Sub Letra_para_permutacoes()
Dim vPalavra As String
vPalavra = InputBox("Entre com sua palavra para permuta:", "Saberexcel - site das Macros", "saberexcel")
If Len(vPalavra) < 2 Then Exit Sub
If Len(S) >= 8 Then
MsgBox "Digite um nome maior que dois e Menor que 8!", vbInformation, "Saberexcel - site das Macros"
Exit Sub
Else
ActiveSheet.Columns(1).Clear
LinhaCorrente = 1
Call Permutacoes("", vPalavra)
End If
End Sub

Sub Permutacoes(X As String, Y As String)
' The source of this algorithm is unknown
Dim i As Integer, j As Integer
On Error GoTo SaberExcel_Err
j = Len(Y)
If j < 2 Then
Cells(LinhaCorrente, 1) = X & Y
LinhaCorrente = LinhaCorrente + 1
[c6].Value = "Interações realizadas [ " & LinhaCorrente & " ]" _
& " com a palavra [ " & [a1].Value & " ] - Núm de caracteres: [" & [G1].Value & " ] - [Saberexcel - O site das macros ]"
Else
For i = 1 To j
Call Permutacoes(X + Mid(Y, i, 1), _
Left(Y, i - 1) + Right(Y, j - i))
Next
End If
Exit Sub
SaberExcel_Err: MsgBox ("Maximo de linhas usadas use ms excel 2010"), vbInformation, "Saberexcel Site das Macros"
End
End Sub

--- BAIXE O EXEMPLO DE PLANIHA NO FINAL DA PÁGINA:--------

Essa planilha faz parte do Módulo COMO FAZER - Trabalhando com Loops
INSTRUÇÕES LOOP \While...Wend\Do...While...Loop\Do...Loop...While\Do...until..Loop\Do...Loop...until\For...Next\For...Each...next
'--------------------'
1 - INSTRUÇÃO: WHILE...WEND - Enquanto ... Faça Loop Wend Enquanto a condição for atendida, o loop novamente '
--------------------'
2 - INSTRUÇÃO: DO...WHILE...LOOP - Enquanto ... Loop Wend Enquanto a condição for atendida, o loop é executado
'--------------------'
3 - INSTRUÇÃO: DO...LOOP...WHILE - Loop Do ... Loop While O loop é executado, em seguida, repita até que a condição é satisfeita '
--------------------'
4 - INSTRUÇÃO: DO...UNTIL..LOOP - Loop Do Until ... Loop Até que a condição é alcançada, o loop é executado
'--------------------'
5 - INSTRUÇÃO: DO...LOOP...UNTIL - Loop Do ... Loop Until O loop é executado, então se repete até que a condição for atendida
'--------------------'
6 - INSTRUÇÃO: FOR...NEXT Instrução Loop - Repete uma série de instruções de um número de vezes 7 - INSTRUÇÃO: FOR..EACH...NEXT
O laço For Each ... Próximo Repete um bloco de instruções para cada objeto em uma coleção ou cada elemento de um array '
--------------------'

INSTRUÇÕES LOOP - ESTUDADAS NAS 100 Planilhas exemplos
Adquira já as planilhas para treinamento com Loops - http://www.microsoftexcel.com.br
1 - WHILE...WEND
2 - DO...WHILE...LOOP
3 - DO...LOOP...WHILE
4 - DO...UNTIL..LOOP
5 - DO...LOOP...UNTIL
6 - FOR...NEXT
7 -FOR..EACH...NEXT


Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.