How to generate a permutation from three sets of numbers where each columnn consists 0 to 9

R

rkhadka

New Member
Joined
May 21, 2011
Messages
4
Hi all, I am pretty new to VBA and do not use it much. I locked my suitcase and forgot the password and hence want to use the permutations to strike off any key combination I have tried.:( I want to create a macro and this should give me the list of 17550 permutaions from three columns which contain 0 to 9. I want to try this as I have been trying to open it from such a long time. Not a good method I understand but there is no locksmith around and we could not break the lock anyway...might as well try this new method!:(
 
Last edited:

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
Wouldn't there be a total of 1000 permutations? 10^3?
Something like:
0 0 0
0 0 1
0 0 2
.
.
.
9 9 8
9 9 9
 
Upvote 0
To get a list of all possible permutations, you could set up your sheet like this:
Data

<TABLE style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Calibri,Arial; FONT-SIZE: 11pt" border=1 cellSpacing=0 cellPadding=0><COLGROUP><COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 76px"><COL style="WIDTH: 93px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"><COL style="WIDTH: 64px"></COLGROUP><TBODY><TR style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt; FONT-WEIGHT: bold"><TD></TD><TD>A</TD><TD>B</TD><TD>C</TD><TD>D</TD><TD>E</TD><TD>F</TD><TD>G</TD><TD>H</TD><TD>I</TD><TD>J</TD><TD>K</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">1</TD><TD></TD><TD style="TEXT-ALIGN: right">0</TD><TD style="TEXT-ALIGN: right">1</TD><TD style="TEXT-ALIGN: right">2</TD><TD style="TEXT-ALIGN: right">3</TD><TD style="TEXT-ALIGN: right">4</TD><TD style="TEXT-ALIGN: right">5</TD><TD style="TEXT-ALIGN: right">6</TD><TD style="TEXT-ALIGN: right">7</TD><TD style="TEXT-ALIGN: right">8</TD><TD style="TEXT-ALIGN: right">9</TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">2</TD><TD>Slot A</TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</TD><TD>Slot B</TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD></TR><TR style="HEIGHT: 18px"><TD style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</TD><TD>Slot C</TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD><TD></TD></TR></TBODY></TABLE>
And place the following code in a new module (credit goes to shg, I have just adapted his code):
Code: 
Option Explicit
 
Sub SuitcaseKeyPermutations()
    Dim avdKey As Variant
    Dim nKey       As Long
    Dim nSlot       As Long
    Dim KeyRng     As Range
 
    Dim aiInx()     As Long
    Dim aiMin()     As Long
    Dim aiMax()     As Long
 
    Dim i           As Long
    Dim iRow        As Long
    Dim iCol        As Long
    Dim ws As Worksheet
    Dim mySheets As Long
 
    Const calc = "Calc"
 
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
 
    For Each ws In ActiveWorkbook.Worksheets
        If Left(ws.Name, 4) = calc Then ws.Delete
    Next
 
    Set ws = ActiveSheet
 
    sheets.Add
    ActiveSheet.Name = calc & mySheets
 
    Application.DisplayAlerts = True
 
    ws.Range(Sheet1.Cells(1, 2).Address & ":" & Sheet1.Cells(1, Sheet1.Range("IV1").End(xlToLeft).Column).Address).Copy
    Worksheets(calc & mySheets).Cells(1, Sheet1.Range("IV1").End(xlToLeft).Column + 2).PasteSpecial Transpose:=True
    Set KeyRng = Worksheets(calc & mySheets).UsedRange.Columns(1)
    ActiveWorkbook.Names.Add Name:="Keys", RefersTo:=KeyRng
    avdKey = WorksheetFunction.Transpose(Range("Keys"))
    nKey = UBound(avdKey)
    nSlot = Application.CountA(Sheet1.Range("A:A"))
    Worksheets(calc & mySheets).Columns(1).Resize(, nKey).ClearContents
        ReDim aiInx(1 To nSlot)
        ReDim aiMin(1 To nSlot)
        ReDim aiMax(1 To nSlot)
        For i = 1 To nSlot
            aiMin(i) = 1
            aiMax(i) = nKey
        Next i
        GrpPermute aiInx, aiMin, aiMax, True
        Do While GrpPermute(aiInx, aiMin, aiMax)
            If iRow = 50000 Then
                sheets.Add
                mySheets = mySheets + 1
                ActiveSheet.Name = calc & mySheets
                iRow = 0
            End If
            iRow = iRow + 1
            ActiveWindow.ScrollRow = iRow
            For iCol = 1 To nSlot
                ActiveSheet.Cells(iRow, iCol) = avdKey(aiInx(iCol))
            Next iCol
        Loop
    Application.Calculation = xlCalculationAutomatic
 
    ActiveWorkbook.Names("Keys").Delete
 
End Sub
 
Function GrpPermute(aiInx() As Long, aiMin() As Long, aiMax() As Long, _
                    Optional bInit As Boolean = False) As Boolean
    ' shg 2007
 
    ' Changes array aiInx to the next permutation, varying elements between
    ' the min and max values in aiMin and aiMax. The three arrays must all
    ' be 1-based and the same size.
 
    ' To initialize aiInx so that the *next* call returns the first combination,
    ' call with bInit True.
 
    ' Init returns              {aiMin(1), aiMin(2), ... aiMin(m) - 1}
    ' The first permutation is  {aiMin(1), aiMin(2), ... aiMin(m)}
    ' The last is               {aiMax(1), aiMax(2), ... aiMax(m)}
 
    ' Returns False when no more permutations exist
 
    Dim i       As Long
    Dim m       As Long
 
    m = UBound(aiInx)
 
    If bInit Then
        For i = 1 To m - 1
            aiInx(i) = aiMin(i)
        Next i
        aiInx(m) = aiMin(i) - 1
        GrpPermute = True
 
    Else
        For i = m To 1 Step -1
            If aiInx(i) < aiMax(i) Then
                aiInx(i) = aiInx(i) + 1
                Exit For
            End If
            aiInx(i) = aiMin(i)
        Next i
 
        GrpPermute = i > 0
    End If
End Function

Then you would execute the macro from the sheet and it would give all possible permutations in a new sheet. To do it for more slots, like a four or five slot combination lock, you could just add Slot D and Slot E, for example, below Slot C in column A.
 
Upvote 0
syntaxed said:
To get a list of all possible permutations, you could set up your sheet like this:
Data

<table style="BACKGROUND-COLOR: #ffffff; PADDING-LEFT: 2pt; PADDING-RIGHT: 2pt; FONT-FAMILY: Calibri,Arial; FONT-SIZE: 11pt" border="1" cellpadding="0" cellspacing="0"><colgroup><col style="WIDTH: 30px; FONT-WEIGHT: bold"><col style="WIDTH: 76px"><col style="WIDTH: 93px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"><col style="WIDTH: 64px"></colgroup><tbody><tr style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt; FONT-WEIGHT: bold"><td>
</td><td>A</td><td>B</td><td>C</td><td>D</td><td>E</td><td>F</td><td>G</td><td>H</td><td>I</td><td>J</td><td>K</td></tr><tr style="HEIGHT: 18px"><td style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">1</td><td>
</td><td style="TEXT-ALIGN: right">0</td><td style="TEXT-ALIGN: right">1</td><td style="TEXT-ALIGN: right">2</td><td style="TEXT-ALIGN: right">3</td><td style="TEXT-ALIGN: right">4</td><td style="TEXT-ALIGN: right">5</td><td style="TEXT-ALIGN: right">6</td><td style="TEXT-ALIGN: right">7</td><td style="TEXT-ALIGN: right">8</td><td style="TEXT-ALIGN: right">9</td></tr><tr style="HEIGHT: 18px"><td style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">2</td><td>Slot A</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td></tr><tr style="HEIGHT: 18px"><td style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">3</td><td>Slot B</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td></tr><tr style="HEIGHT: 18px"><td style="TEXT-ALIGN: center; BACKGROUND-COLOR: #cacaca; FONT-SIZE: 8pt">4</td><td>Slot C</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td><td>
</td></tr></tbody></table>
And place the following code in a new module (credit goes to shg, I have just adapted his code):
Code: 
Option Explicit



 
Sub SuitcaseKeyPermutations()
    Dim avdKey As Variant
    Dim nKey       As Long
    Dim nSlot       As Long
    Dim KeyRng     As Range
 
    Dim aiInx()     As Long
    Dim aiMin()     As Long
    Dim aiMax()     As Long
 
    Dim i           As Long
    Dim iRow        As Long
    Dim iCol        As Long
    Dim ws As Worksheet
    Dim mySheets As Long
 
    Const calc = "Calc"
 
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
 
    For Each ws In ActiveWorkbook.Worksheets
        If Left(ws.Name, 4) = calc Then ws.Delete
    Next
 
    Set ws = ActiveSheet
 
    sheets.Add
    ActiveSheet.Name = calc & mySheets
 
    Application.DisplayAlerts = True
 
    ws.Range(Sheet1.Cells(1, 2).Address & ":" & Sheet1.Cells(1, Sheet1.Range("IV1").End(xlToLeft).Column).Address).Copy
    Worksheets(calc & mySheets).Cells(1, Sheet1.Range("IV1").End(xlToLeft).Column + 2).PasteSpecial Transpose:=True
    Set KeyRng = Worksheets(calc & mySheets).UsedRange.Columns(1)
    ActiveWorkbook.Names.Add Name:="Keys", RefersTo:=KeyRng
    avdKey = WorksheetFunction.Transpose(Range("Keys"))
    nKey = UBound(avdKey)
    nSlot = Application.CountA(Sheet1.Range("A:A"))
    Worksheets(calc & mySheets).Columns(1).Resize(, nKey).ClearContents
        ReDim aiInx(1 To nSlot)
        ReDim aiMin(1 To nSlot)
        ReDim aiMax(1 To nSlot)
        For i = 1 To nSlot
            aiMin(i) = 1
            aiMax(i) = nKey
        Next i
        GrpPermute aiInx, aiMin, aiMax, True
        Do While GrpPermute(aiInx, aiMin, aiMax)
            If iRow = 50000 Then
                sheets.Add
                mySheets = mySheets + 1
                ActiveSheet.Name = calc & mySheets
                iRow = 0
            End If
            iRow = iRow + 1
            ActiveWindow.ScrollRow = iRow
            For iCol = 1 To nSlot
                ActiveSheet.Cells(iRow, iCol) = avdKey(aiInx(iCol))
            Next iCol
        Loop
    Application.Calculation = xlCalculationAutomatic
 
    ActiveWorkbook.Names("Keys").Delete
 
End Sub
 
Function GrpPermute(aiInx() As Long, aiMin() As Long, aiMax() As Long, _
                    Optional bInit As Boolean = False) As Boolean
    ' shg 2007
 
    ' Changes array aiInx to the next permutation, varying elements between
    ' the min and max values in aiMin and aiMax. The three arrays must all
    ' be 1-based and the same size.
 
    ' To initialize aiInx so that the *next* call returns the first combination,
    ' call with bInit True.
 
    ' Init returns              {aiMin(1), aiMin(2), ... aiMin(m) - 1}
    ' The first permutation is  {aiMin(1), aiMin(2), ... aiMin(m)}
    ' The last is               {aiMax(1), aiMax(2), ... aiMax(m)}
 
    ' Returns False when no more permutations exist
 
    Dim i       As Long
    Dim m       As Long
 
    m = UBound(aiInx)
 
    If bInit Then
        For i = 1 To m - 1
            aiInx(i) = aiMin(i)
        Next i
        aiInx(m) = aiMin(i) - 1
        GrpPermute = True
 
    Else
        For i = m To 1 Step -1
            If aiInx(i) < aiMax(i) Then
                aiInx(i) = aiInx(i) + 1
                Exit For
            End If
            aiInx(i) = aiMin(i)
        Next i
 
        GrpPermute = i > 0
    End If
End Function
Then you would execute the macro from the sheet and it would give all possible permutations in a new sheet. To do it for more slots, like a four or five slot combination lock, you could just add Slot D and Slot E, for example, below Slot C in column A.
Click to expand...


Thank you so much! perfect...now starting my trial and error!:) and yes it is 1000, not 17000!:smile:Cheers!
 
Upvote 0
Hi

In this case, since you just want the numbers 0-999, like syntaxed said in post #3, you can also write in A1:

=text(row()-1,"000")

and copy down till A1000
 
Upvote 0
Late to the party, but this should also work
Code: 
Sub Permutations()
    Dim i As Integer, MyNumber As Long, j As Integer, NumFormat As String
    j = Application.InputBox("How many columns?", Type:=1)
    For i = 1 To j
        MyNumber = MyNumber & "9"
        NumFormat = NumFormat + "0"
    Next i
    Application.ScreenUpdating = False
    For i = 0 To MyNumber
        For j = 1 To Len(MyNumber)
            Cells(i + 1, j).Value = Mid(Format(i, NumFormat), j, 1)
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
How to filter sets of "n" number of numbers from a list and make an output list corresponding to the averages of those sets?
Replies
4
Views
447
Rnkhch
R
M
  • Solved
From the 8 numbers, generate permutations with set of 9 numbers, with target sum of 7
2
Replies
15
Views
1K
motilulla
M
A
  • Question Question
Want to generate tables from column of data thru VBA.
Replies
1
Views
469
AGU
A
C
  • Question Question
How do I skip rows?
Replies
6
Views
374
StephenCrump
S
L
  • Question Question
Football League Table Generation
Replies
1
Views
851
footoo
F

Forum statistics

Threads
1,224,514
Messages
6,179,219
Members
452,895
Latest member
BILLING GUY

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top