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