PDA

View Full Version : Solved: VBA code for checking possible combinations of 4 numeric digits



LeoLee
06-29-2011, 03:11 AM
Hi Everyone,

I have a pretty complicated requirements here and hope any experts can assist me in my problems.

I am required to generate the possible combinations for 4 numeric digits and to display all the combination in the sheets. For example: 1245

The possible combinations are:
5421, 5412, 4512, 4521... so on and so forth...

1245 can generate a totall of 24 combinations as all the 4 numbers are different.

1244 can generate a total of 12 combinations as 2 of the numbers are the same.

1444 can generate a total of 6 combinations as 3 of the numbers are the same.

I have come out a very in-efficient formular by using left, mid and right to change the position. However, it possess 1 big problem. It can only deal with 24 combinations set numeric as it is pretty hard coded in the sense that it change the position of the numeric.

I have attached the excel sheet that I have done. I also need it to display as per the attached excel file ><"

Hense, I believe the only solution is to use VBA to deal with my problems. However, I am really bad in VBA especially i believe alot of looping is needed to solve it!

I really appreciate if anyone could assist me in this matter. :(

Really thanks for your time to read my thread!

Looking forward to your reply!

Leo Lee

GTO
06-29-2011, 09:44 PM
Greetings Leo,

I'm sure there's a better way, but try this in the meantime:

Sub Main()
Dim MyString As String
Dim ary As Variant
Dim LS As String, RS As String

MyString = Application.InputBox("Input number to return unique permutations:", vbNullString, , , , , , 2)
If Len(MyString) < 2 Or Len(MyString) > 7 Then
MsgBox "The number either has only one digit, or is too great and may error. Now exiting.", 0, vbNullString
Exit Sub
End If

RS = MyString

Call RetUniquePerms(LS, RS, ary)
'// Plunk the return wherever, re-call the function to kill the current dictionary//
Range("C1").Resize(UBound(ary) + 1).Value = Application.Transpose(ary)
Call RetUniquePerms(LS, RS, ary, True)

End Sub

Function RetUniquePerms(LeftSide As String, RightSide As String, ary As Variant, Optional KillDic As Boolean)
Dim lLen As Long, i As Long
Static DIC As Object

If KillDic Then
Set DIC = Nothing
Exit Function
End If

If DIC Is Nothing Then Set DIC = CreateObject("Scripting.Dictionary")

lLen = Len(RightSide)

If lLen < 2 Then
DIC.Item(CLng(LeftSide & RightSide)) = Empty
Else
For i = 1 To lLen
Call RetUniquePerms(LeftSide + Mid(RightSide, i, 1), _
Left(RightSide, i - 1) + Right(RightSide, lLen - i), ary)
Next
End If
ary = DIC.Keys
End Function
Hope that helps,

Mark

jolivanes
06-29-2011, 10:21 PM
Leo
I had this file (see attachment) stashed away somewhere.
Of any help?

I don't know who the person is that made it so I can't give accolades.

Regards
John

LeoLee
06-29-2011, 10:45 PM
Dear GTO,

Your VBA code was AWESOME! This is exactly what I am looking for!

However, it has 1 little problem that I might need your help in assisting me for the code. As my VBA code skills are not very advance especially to deal with such complex criteria.

1 of the loop hole in excel is that when u key in 0012, it will naturally display 12 and eliminate the 00.

So when I key in the combination of 0001 with your code, it will show 4 combinations, however, it will eliminate 000 infront. Is there a way to display the '0's?

Another small request is that I need to display the combination in this following format:

for example 1234:

1234, 1243, 1324, 1342, 1423, 1432

2134, 2143, 2314, 2341, 2413, 2431

so on and so forth.... .... .... ...

Which mean 6 results in a row.

I would really like to thank you and really appreciate for your help! THANK YOU THANK YOU!

Dear Jolivanes,

THANK you for your effort in attaching the following Excel file! It works GREAT! However, it possesses the same problems ><"

If in any way u know how to edit the code, please do assist me!

Once again Thank You!!!! !!!

GTO
06-29-2011, 11:49 PM
...1 of the loop hole in excel is that when u key in 0012, it will naturally display 12 and eliminate the 00.

So when I key in the combination of 0001 with your code, it will show 4 combinations, however, it will eliminate 000 infront. Is there a way to display the '0's? ...

Poorly tested and I am not sure if this gets rid of duplicates with the zeros included. I think you'd just want to change the numberformat of the destination cells to keep preceeding zeros. Also, you'll see that I ditched CLng() which would have also gotten rid of them, as I thought that we were doing numbers.

Again, not sure, but maybe:

Option Explicit

Sub Main()
Dim MyString As String
Dim ary As Variant
Dim aryOutput() As String
Dim i As Long, ii As Long, n As Long
Dim LS As String, RS As String

MyString = Application.InputBox("Input number to return unique permutations:", vbNullString, , , , , , 2)
If Len(MyString) < 2 Or Len(MyString) > 8 Then
MsgBox "The number either has only one digit, or is too great and may error. Now exiting.", 0, vbNullString
Exit Sub
End If

RS = MyString

Call RetUniquePerms(LS, RS, ary)

ReDim aryOutput(1 To (((UBound(ary) - LBound(ary) + 1) / 6) * 2 + 2), 1 To 6)

On Error GoTo ExceededArray
For i = 1 To UBound(aryOutput, 1) Step 2
For ii = 1 To 6
aryOutput(i, ii) = ary(n)
n = n + 1
Next
Next
ExceededArray:

With Range("H8").Resize(UBound(aryOutput, 1), 6)
.NumberFormat = "@"
.Value = aryOutput
End With
Call RetUniquePerms(LS, RS, ary, True)
End Sub

Function RetUniquePerms(LeftSide As String, RightSide As String, ary As Variant, Optional KillDic As Boolean)
Dim lLen As Long, i As Long
Static DIC As Object

If KillDic Then
Set DIC = Nothing
Exit Function
End If

If DIC Is Nothing Then Set DIC = CreateObject("Scripting.Dictionary")

lLen = Len(RightSide)

If lLen < 2 Then
DIC.Item(LeftSide & RightSide) = Empty
Else
For i = 1 To lLen
Call RetUniquePerms(LeftSide & Mid(RightSide, i, 1), _
Left(RightSide, i - 1) & Right(RightSide, lLen - i), ary)
Next
End If
ary = DIC.Keys
End Function
Hope that helps,

Mark