Thanks guys that is what i looked.

For more than couple chars (I ve checked for string contained 9 items) time
of generation was a very very long.

Thanks again.

Uzytkownik napisal w wiadomosci
oups.com...
On 27 Apr, 01:14, "RB Smissaert"
wrote:
Don't think it is the fastest way to do this, but it does work:

Sub test()

Dim i As Long
Dim n As Long
Dim lVal As Long
Dim coll As Collection
Dim arr
Dim str1 As String
Dim str2 As String

Cells.Clear

arr = Array("t", "a", "t", "5")

Set coll = New Collection

On Error Resume Next

For i = 1234 To 4321

str1 = ""
str2 = ""

For n = 1 To 4
lVal = Val(Mid$(CStr(i), n, 1))

If lVal 4 Or lVal = 0 Then
Exit For
End If

If n = 1 Then
str1 = CStr(lVal)
str2 = arr(lVal - 1)
Else
If InStr(1, str1, CStr(lVal), vbBinaryCompare) = 0 Then
str1 = str1 & lVal
str2 = str2 & arr(lVal - 1)
Else
Exit For
End If
End If

Next n

If Len(str2) = 4 Then
coll.Add str2, str2
End If

Next i

For i = 1 To coll.Count
Cells(i, 1) = coll(i)
Next i

End Sub

RBS

"obar2" wrote in message

...

hello, i have a problem with such example, i have a string let say :
"tat5"
(every in separate cell but it doesn't matter)
And what I need to do is to create loop which shift me this strinh
each
element with each. I mean put ale item on every place.
So in this example shoud loop do:
1. tat5
2. att5
3. at5t
4. ta5t
5. t5at
6. t5ta
7. 5tta
8. t5ta
9. a5tt
10. 5tat
11. 5att
12. and so on....

any idea to do this ?
Thanks for any help and suggestions


This makes it a generic function:

Sub testing()

Dim i As Long
Dim coll As Collection

Set coll = GetUniqueCombinations("tat5")

Cells.Clear

For i = 1 To coll.Count
Cells(i, 1) = coll(i)
Next i

End Sub

Function GetUniqueCombinations(strString As String) As Collection

Dim i As Long
Dim n As Long
Dim z As Long
Dim lLen As Long
Dim lMin As Long
Dim lMax As Long
Dim lVal As Long
Dim arr
Dim str1 As String
Dim str2 As String

lLen = Len(strString)

ReDim arr(1 To lLen) As String

For n = 1 To lLen
'fill the character array
'------------------------
arr(n) = Mid$(strString, n, 1)

'get the minimum and maximum of the outer loop
'---------------------------------------------
If n = 1 Then
z = 1
Else
z = z * 10
End If
lMax = lMax + z * n
lMin = lMin + (lLen + 1 - n) * z
Next n

Set GetUniqueCombinations = New Collection

'to avoid an error when trying to add a duplicate collection item
'----------------------------------------------------------------
On Error Resume Next

For i = lMin To lMax

str1 = ""
str2 = ""

For n = 1 To lLen
lVal = Val(Mid$(CStr(i), n, 1))

If lVal lLen Or lVal = 0 Then
Exit For
End If

If n = 1 Then
str1 = CStr(lVal)
str2 = arr(lVal)
Else
'to avoid taking the same element of the character
array more than once

'----------------------------------------------------------------------
If InStr(1, str1, CStr(lVal), vbBinaryCompare) = 0
Then
str1 = str1 & lVal
str2 = str2 & arr(lVal)
Else
Exit For
End If
End If
Next n

If Len(str2) = lLen Then
'testing for uniqueness with the collection index
'------------------------------------------------
GetUniqueCombinations.Add str2, str2
End If

Next i

End Function


RBS