MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Melhorias na Função de Myrna Larson - Gerar combinações e Permutações MS Access

    Compartilhe

    luthius
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1
    Registrado : 05/05/2013

    Melhorias na Função de Myrna Larson - Gerar combinações e Permutações MS Access

    Mensagem  luthius em Seg 22 Jun 2015, 19:45

    Pessoal, a idéia do código abaixo é gerar Combinações e Permutações de uma faixa de números.
    Este código foi desenvolvido para excel, porém gostaria da ajuda de vocês em torna-lo mais abrangente onde poderá atender o Access também.

    Código:

    'Option Explicit
    '*******************************************************************************
    ' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc
    ' http://www.mydatabasesupport.com/forums/spreadsheets/250560-combinations.html
    '*******************************************************************************
    Dim vAllItems As Variant
    Dim Buffer() As String
    Dim BufferPtr As Long
    Dim Results As Worksheet
    Private Sub AddPermutation(Optional PopSize As Integer = 0, _
                              Optional SetSize As Integer = 0, _
                              Optional NextMember As Integer = 0)


    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Static Used() As Integer
    Dim i As Integer


       If PopSize <> 0 Then
           iPopSize = PopSize
           iSetSize = SetSize
           ReDim SetMembers(1 To iSetSize) As Integer
           ReDim Used(1 To iPopSize) As Integer
           NextMember = 1
       End If
      
       For i = 1 To iPopSize
           If Used(i) = 0 Then
               SetMembers(NextMember) = i
               If NextMember <> iSetSize Then
                   Used(i) = True
                   AddPermutation , , NextMember + 1
                   Used(i) = False
               Else
                   SavePermutation SetMembers()
               End If
           End If
       Next i
      
       If NextMember = 1 Then
           SavePermutation SetMembers(), True
           Erase SetMembers
           Erase Used
       End If


    End Sub


    Private Sub AddCombination(Optional PopSize As Integer = 0, _
                              Optional SetSize As Integer = 0, _
                              Optional NextMember As Integer = 0, _
                              Optional NextItem As Integer = 0)


    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Dim i As Integer
      
       If PopSize <> 0 Then
           iPopSize = PopSize
           iSetSize = SetSize
           ReDim SetMembers(1 To iSetSize) As Integer
           NextMember = 1
           NextItem = 1
       End If
      
       For i = NextItem To iPopSize
           SetMembers(NextMember) = i
           If NextMember <> iSetSize Then
               AddCombination , , NextMember + 1, i + 1
               Debug.Print NextMember
           Else


               SavePermutation SetMembers()
           End If
       Next i
      
       If NextMember = 1 Then
           SavePermutation SetMembers(), True
           Erase SetMembers
       End If


    End Sub


    Private Sub SavePermutation(ItemsChosen() As Integer, _
                               Optional FlushBuffer As Boolean = False)
    Dim i As Long, sValue As String
    Static RowNum As Long, ColNum As Long
      
       If RowNum = 0 Then RowNum = 1
       If ColNum = 0 Then ColNum = 1
      
       If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
           If BufferPtr > 0 Then
               If (RowNum + BufferPtr - 1) > Rows.Count Then
                   RowNum = 1
                   ColNum = ColNum + 1
                   If ColNum > 256 Then Exit Sub
               End If
          
           Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
               = Application.WorksheetFunction.Transpose(Buffer())
           RowNum = RowNum + BufferPtr
           'End If
          
           BufferPtr = 0
           If FlushBuffer = True Then
               Erase Buffer
               RowNum = 0
               ColNum = 0
               Exit Sub
           Else
               ReDim Buffer(1 To UBound(Buffer))
           End If
      


       'construct the next set
       For i = 1 To UBound(ItemsChosen)
           '************************************************************
    '       Debug.Print vAllItems(ItemsChosen(i)) ', 1)
           'With comma space
           sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
     '      Debug.Print sValue
           'Without comma space
           'sValue = sValue & vAllItems(ItemsChosen(i), 1)
           '************************************************************
          
       Next i
       'and save it in the buffer
       BufferPtr = BufferPtr + 1
       Buffer(BufferPtr) = Mid$(sValue, 3)
    End Sub 'SavePermutation

    ahteixeira
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3217
    Registrado : 15/03/2013

    Re: Melhorias na Função de Myrna Larson - Gerar combinações e Permutações MS Access

    Mensagem  ahteixeira em Dom 19 Jul 2015, 22:43

    Olá Luthius, bem-vindo ao fórum.

    Parece interessante o código, no entanto poderia descrever um exemplo em que pode ser utilizado e o que faz concretamente.

    Abraço

    ahteixeira
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3217
    Registrado : 15/03/2013

    Re: Melhorias na Função de Myrna Larson - Gerar combinações e Permutações MS Access

    Mensagem  ahteixeira em Ter 13 Out 2015, 08:36

    Up

      Data/hora atual: Sab 10 Dez 2016, 04:53