VB Code for Create Possible Combination From given Numbers in Excel

This is the vb Example for the permutation without repetition in excel 


Function ListPermut(str As String, num As Integer)
'Permutations without repetition
Dim c, r, p As Long
Dim rng() As Long, temp As Long, i As Long
Dim temp1 As Long, y() As Long, d As Long
Dim tmpOut(), tmpArr() As Variant
Dim j As Integer
Dim a As Boolean
ReDim tmpArr(0)
ReDim tmpOut(0)
For j = 1 To Len(str)
    tmpArr(UBound(tmpArr)) = Mid(str, j, 1)
    ReDim Preserve tmpArr(UBound(tmpArr) + 1)
Next j
ReDim Preserve tmpArr(UBound(tmpArr) - 1)
p = WorksheetFunction.Permut(Len(str), Len(str))
ReDim rng(1 To p, 1 To Len(str))
For c = 1 To Len(str)
  rng(1, c) = c
Next c
For r = 2 To p
    For c = 1 To num
      tmpOut(UBound(tmpOut)) = tmpOut(UBound(tmpOut)) & tmpArr(rng(r - 1, c) - 1)
    Next c
   
    If UBound(tmpOut) <> 0 Then
        If tmpOut(UBound(tmpOut)) = tmpOut(UBound(tmpOut) - 1) Then
            tmpOut(UBound(tmpOut)) = ""
        Else
            ReDim Preserve tmpOut(UBound(tmpOut) + 1)
        End If
    Else
        ReDim Preserve tmpOut(UBound(tmpOut) + 1)
    End If
For c = Len(str) To 1 Step -1
  If rng(r - 1, c - 1) < rng(r - 1, c) Then
    temp = c - 1
    Exit For
  End If
Next c
 
  For c = Len(str) To 1 Step -1
    rng(r, c) = rng(r - 1, c)
  Next c

  For c = Len(str) To 1 Step -1
      If rng(r - 1, c) > rng(r - 1, temp) Then
          temp1 = rng(r - 1, temp)
          rng(r, temp) = rng(r - 1, c)
          rng(r, c) = temp1
          ReDim y(Len(str) - temp)
          i = 0
          For d = temp + 1 To Len(str)
            y(i) = rng(r, d)
            i = i + 1
          Next d
          i = 0
          For d = Len(str) To temp + 1 Step -1
            rng(r, d) = y(i)
            i = i + 1
          Next d
          Exit For
      End If
  Next c
 
If r = p Then
    For c = 1 To num
      tmpOut(UBound(tmpOut)) = tmpOut(UBound(tmpOut)) & tmpArr(rng(r, c) - 1)
    Next c
    If tmpOut(UBound(tmpOut)) = tmpOut(UBound(tmpOut) - 1) Then
        ReDim Preserve tmpOut(UBound(tmpOut) - 1)
    End If
End If
Next r
 
ListPermut = Application.Transpose(tmpOut)
End Function

0 Comments