Excel VBA - Permutas

  • - Acesso Livre
  • Documentos

    Ordenar por : Nome | Data | Acessos [ Ascendente ]

    vba permuta letras de uma palavra mostra novo livro vba permuta letras de uma palavra mostra novo livro

    popular!
    Adicionado em: 27/11/2010
    Modificado em: 27/11/2010
    Tamanho: Vazio
    Downloads: 1173

    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

    Eletrônicos - Submarino.com.br

    Excel planilha vba interações e permutas palavras Excel planilha vba interações e permutas palavras

    popular!
    Adicionado em: 13/10/2011
    Modificado em: 13/10/2011
    Tamanho: Vazio
    Downloads: 1013

    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.






    PROMOÇÃO DIDÁTICOS SABEREXCEL



    Adquira já o Acesso Imediato
    à Area de Membros

    Compra Grantida --- Entrega Imediata

    Aprenda Excel VBA com Simplicidade de 
    códigos e Eficácia, Escrevendo Menos e
    Fazendo Mais.

    '-------------------------------------'
    Entrega Imediata:
    +  500 Video Aulas MS Excel VBA
    +  35.000 Planilhas Excel e VBA
    +  Coleção 25.000 Macros MS Excel VBA
    +  141 Planilhas Instruções Loops
    +  341 Planilhas WorksheetFunctions(VBA)
    +    04 Módulos Como Fazer Excel VBA
    +  Curso Completo MS Excel VBA
    +  Planilhas Inteligentes


    Pesquisa Google SaberExcel

    Publicidade Google

    <script type="text/javascript"><!--

    google_ad_client = "ca-pub-2317234650173689";

    /* retangulo 336 x 280 */

    google_ad_slot = "0315083363";

    google_ad_width = 336;

    google_ad_height = 280;

    //-->

    </script>

    <script type="text/javascript"

    src="http://pagead2.googlesyndication.com/pagead/show_ads.js">

    </script>

    Publicidade

    RSFirewallProtected


    Google Associados

    Depoimentos

    Adicione Saberexcel Favoritos

     
     

    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA

    Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel,


       Sobre as WorksheetFunctions Funções de Planilhas que retornam valores do VBA