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

[LeoLee]

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]

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]

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]

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]

...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