I have a textbox on a sheet to get its value to be used as the criteria of AutoFilter.
The value of textbox is numbers and the multiplication factor is asterisk "*".
There is no issue if the value is only one string e.g "2" or "5".
But, there are cases that the string will be like "1*2" or "10*12*14"
The problem is order of the multiplied numbers differs from someone input to another one,
Meaning: "1*2" can be inputted as "2*1 by another one"
and "10*12*14" can be inputted as "12*10*14" or "14*12*10" and so on.
So, if the value of textbox contains multiplied numbers, then:
I need to get all possible permutations of string array without duplicates on any element (as stated earlier).
the expected result will be used as the criteria of AutoFilter.
I tried the below code and it dose not work as I need, as it produce a lot of duplicates of array elements.
Sub Main()
Dim size As Long, c As Variant, n As Long, arr
Dim tbx4 As String, factors() As String
tbx4 = "10*12*14" 'ActiveSheet.TextBox4.value
factors = Split(tbx4, "*")
size = UBound(factors) + 1
c = factors
n = UBound(c) + 1: ReDim arr(size - 1)
EmbeddedLoops 0, size, c, n, arr
End Sub
Function EmbeddedLoops(index, k, c, n, arr)
Dim i As Variant
If index >= k Then
PrintArrayOnSingleLine arr
Else
For Each i In c
arr(index) = i
EmbeddedLoops index + 1, k, c, n, arr
Next i
End If
End Function
Sub PrintArrayOnSingleLine(myArray As Variant)
Dim counter As Integer, textArray As String
For counter = LBound(myArray) To UBound(myArray)
textArray = textArray & myArray(counter)
Next counter
Debug.Print textArray
End Sub
This is how I would do it:
Option Explicit
Sub Main()
Dim n As Long, i As Long, k As Long, ptr As Long, possibles As Long, arr() As String
Dim tbx4 As String, factors() As String
tbx4 = "10*12*14*16*18" 'ActiveSheet.TextBox4.value
factors = Split(tbx4, "*")
n = UBound(factors)
k = n
possibles = n + 1
Do While k > 1
possibles = possibles * k
k = k - 1
Loop
ReDim arr(possibles - 1)
ptr = 0
For i = 0 To n
Call FillArray(arr, factors, ptr)
Next
Dim tmp As String
For k = 0 To possibles - 1
arr(k) = Right(arr(k), Len(arr(k)) - 1)
Debug.Print arr(k)
Next
End Sub
Sub FillArray(arr() As String, elements() As String, ByRef ptr As Long)
Dim i As Integer, k As Integer, l As Integer, element As String, possibles As Integer, m As Integer
Dim subelements() As String, subptr As Long
Dim subarr() As String
ptr = 0
For i = 0 To UBound(elements)
element = elements(i)
If UBound(elements) > 0 Then
ReDim subelements(UBound(elements) - 1)
l = 0
For k = 0 To UBound(elements)
If k <> i Then
subelements(l) = elements(k)
l = l + 1
End If
Next
possibles = UBound(subelements) + 1
m = possibles - 1
Do While m > 1
possibles = possibles * m
m = m - 1
Loop
ReDim subarr(possibles - 1)
subptr = 0
Call FillArray(subarr, subelements, subptr)
If UBound(subelements) = 0 Then
arr(ptr) = "*" + element + "*" + subelements(0)
ptr = ptr + 1
Else
For m = 0 To UBound(subarr)
arr(ptr) = "*" + element + subarr(m)
ptr = ptr + 1
Next
End If
End If
Next
End Sub
By way of explanation. Firstly I calculate the number of possible permutations. For any number of factors n, the number of permutations is given by n * n - 1 * n - 2 ... until n - x is 1. Effectively we only need to go down to * 2, since * 1 yields the same answer. I then dimension the answer array accordingly.
We then need an iterative function to fill this array with the possible values. Note that I am passing a pointer by reference into this function. This is because I am filling the answers by a fixed pattern, to ensure completeness. Take a,b,c,d as examples. There are 24 possible combinations: these I generate effectively in batches of six, starting with each of the given letters, so the first six in the answer begin with a and the last 6 with d. But my outer loop in this case would only run four times, hence the requirement for a pointer that gets advanced within the iterative function. Obviously your case is easier with only three factors, but I have written my answer to be extensible.