Saberexcel - O site de quem precisa aprender Macros Microsoft Excel VBA 
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 planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel
Baixe o exemplo de planilha das macros e funções acima
Excel planilha vba permuta letras de uma palavra mostra novo livro (43.09 kb)
