MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

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, 18: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
    avatar
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 4650
    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, 21: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
    avatar
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 4650
    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, 07:36

    Up

      Data/hora atual: Qua 13 Dez 2017, 18:44