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

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


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

Up