Added a statusbar progress.

Sub StatusProgressBar(lCounter As Long, _
lMax As Long, _
lInterval As Long, _
Optional strText As String)

Dim lStripes As Long

If lCounter Mod lInterval = 0 Then
lStripes = Round((lCounter / lMax) * 100, 0)
Application.StatusBar = strText & _
String(lStripes, "|") & _
String(100 - lStripes, ".") & "|"
End If

End Sub

Function PermuteString(strString As String, _
Optional strSeparator As String, _
Optional bUnique As Boolean, _
Optional coll As Collection, _
Optional bStringResult As Boolean, _
Optional strTextFileDump As String, _
Optional lDumpThreshold As Long = 2000, _
Optional bShowProgress As Boolean, _
Optional bTextFileDumpNA As Boolean, _
Optional lCombinationCounterNA As Long, _
Optional strBaseNA As String, _
Optional lLenStringNA As Long, _
Optional lLenSeparatorNA As Long, _
Optional bUniqueCharsNA As Boolean, _
Optional strTextDumpNA As String, _
Optional lCounterNA As Long, _
Optional lPermutNA As Long, _
Optional lProgressInterval As Long) As String

'----------------------------------------------------------------------------
'adapted code from:
'http://www.codeguru.com/vb/gen/vb_misc/algorithms/article.php/c5607/#more
'----------------------------------------------------------------------------
'don't assign values to these last 10 arguments:
'----------------------------------------------
'lCombinationCounterNA - this will pick up the number of combinations
'bTextFileDumpNA - putting in the path of the text file will cause
the text dump
'strBaseNA
'lLenStringNA
'lLenSeparatorNA
'bUniqueCharsNA
'strTextDumpNA
'lCounterNA
'lPermutNA
'lProgressInterval
'----------------------------------------------------------------------------
'bUnique only applies to values added to the collection, so a produced
string
'or values dumped to text file can be duplicates, even with bUnique = True
'----------------------------------------------------------------------------

Dim i As Long
Dim strTemp As String
Dim strTemp2 As String
Dim bDumped As Boolean

If lLenStringNA = 0 Then
lLenStringNA = Len(strString)
lLenSeparatorNA = Len(strSeparator)
bUniqueCharsNA = OnlyUniqueCharsInString(strString)
bTextFileDumpNA = Len(strTextFileDump) 0
lPermutNA = Application.WorksheetFunction.Permut(lLenStringNA,
lLenStringNA)
If lPermutNA < 1000 Then
bShowProgress = False
End If
If bShowProgress Then
lProgressInterval = (lPermutNA \ 10000) * 100
If lProgressInterval = 0 Then
bShowProgress = False
End If
End If
'as this won't otherwise be picked up
'------------------------------------
If lLenStringNA = 1 Then
lCombinationCounterNA = 1
End If
If bTextFileDumpNA Then
'to start with a new file
'------------------------
If bFileExists(strTextFileDump) Then
Kill strTextFileDump
End If
End If
End If

If Len(strString) = 1 Then
PermuteString = strBaseNA & strString & strSeparator
Exit Function
End If

If bUnique Then
'to avoid an error when adding a duplicate key to the collection
'---------------------------------------------------------------
On Error Resume Next
End If

If Len(strBaseNA) = 0 Then
For i = 1 To Len(strString)
strTemp = PermuteString(ReturnAllBut(strString, i), _
strSeparator, _
bUnique, _
coll, _
bStringResult, _
strTextFileDump, _
lDumpThreshold, _
bShowProgress, _
bTextFileDumpNA, _
lCombinationCounterNA, _
Mid$(strString, i, 1), _
lLenStringNA, _
lLenSeparatorNA, _
bUniqueCharsNA, _
strTextDumpNA, _
lCounterNA, _
lPermutNA, _
lProgressInterval)

lCounterNA = lCounterNA + 1
If bStringResult Then
PermuteString = PermuteString & strTemp
End If
Next i
Else 'If Len(strBaseNA) = 0
If coll Is Nothing Then
For i = 1 To Len(strString)
strTemp = PermuteString(ReturnAllBut(strString, i), _
strSeparator, _
bUnique, _
coll, _
bStringResult, _
strTextFileDump, _
lDumpThreshold, _
bShowProgress, _
bTextFileDumpNA, _
lCombinationCounterNA, _
strBaseNA & Mid$(strString, i, 1), _
lLenStringNA, _
lLenSeparatorNA, _
bUniqueCharsNA, _
strTextDumpNA, _
lCounterNA, _
lPermutNA, _
lProgressInterval)

If bStringResult Then
PermuteString = PermuteString & strTemp
End If

If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then
lCombinationCounterNA = lCombinationCounterNA + 1
If bShowProgress Then
StatusProgressBar lCombinationCounterNA, lPermutNA,
lProgressInterval, _
lCombinationCounterNA & "/" & lPermutNA & " -
"
End If
If bTextFileDumpNA Then
If Len(strTextDumpNA) lDumpThreshold Then
'take the trailing separator off to avoid blank lines in the
text file
'---------------------------------------------------------------------
strTextDumpNA = strTextDumpNA & Left$(strTemp, Len(strTemp) -
Len(strSeparator))
SaveToTextAppend strTextDumpNA, strTextFileDump
bDumped = True
strTextDumpNA = ""
Else
strTextDumpNA = strTextDumpNA & strTemp
End If
End If 'If bTextFileDumpNA
End If

Next i

Else 'If coll Is Nothing
'no need to test for uniqueness if characters in string are all unique
'---------------------------------------------------------------------
If bUnique And bUniqueCharsNA = False Then
For i = 1 To Len(strString)
strTemp = PermuteString(ReturnAllBut(strString, i), _
strSeparator, _
True, _
coll, _
bStringResult, _
strTextFileDump, _
lDumpThreshold, _
bShowProgress, _
bTextFileDumpNA, _
lCombinationCounterNA, _
strBaseNA & Mid$(strString, i, 1), _
lLenStringNA, _
lLenSeparatorNA, _
bUniqueCharsNA, _
strTextDumpNA, _
lCounterNA, _
lPermutNA, _
lProgressInterval)

If bStringResult Then
PermuteString = PermuteString & strTemp
End If

If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then
lCombinationCounterNA = lCombinationCounterNA + 1
If bShowProgress Then
StatusProgressBar lCombinationCounterNA, lPermutNA,
lProgressInterval, _
lCombinationCounterNA & "/" & lPermutNA &
" - "
End If
strTemp2 = Left$(strTemp, lLenStringNA)
coll.Add strTemp2, strTemp2
If bTextFileDumpNA Then
If Len(strTextDumpNA) lDumpThreshold Then
strTextDumpNA = strTextDumpNA & Left$(strTemp,
Len(strTemp) - Len(strSeparator))
SaveToTextAppend strTextDumpNA, strTextFileDump
bDumped = True
strTextDumpNA = ""
Else
strTextDumpNA = strTextDumpNA & strTemp
End If
End If 'If bTextFileDumpNA
End If

Next i

Else 'If bUnique
For i = 1 To Len(strString)
strTemp = PermuteString(ReturnAllBut(strString, i), _
strSeparator, _
False, _
coll, _
bStringResult, _
strTextFileDump, _
lDumpThreshold, _
bShowProgress, _
bTextFileDumpNA, _
lCombinationCounterNA, _
strBaseNA & Mid$(strString, i, 1), _
lLenStringNA, _
lLenSeparatorNA, _
bUniqueCharsNA, _
strTextDumpNA, _
lCounterNA, _
lPermutNA, _
lProgressInterval)

If bStringResult Then
PermuteString = PermuteString & strTemp
End If

If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then
lCombinationCounterNA = lCombinationCounterNA + 1
If bShowProgress Then
StatusProgressBar lCombinationCounterNA, lPermutNA,
lProgressInterval, _
lCombinationCounterNA & "/" & lPermutNA &
" - "
End If
coll.Add Left$(strTemp, lLenStringNA)
If bTextFileDumpNA Then
If Len(strTextDumpNA) lDumpThreshold Then
strTextDumpNA = strTextDumpNA & Left$(strTemp,
Len(strTemp) - Len(strSeparator))
SaveToTextAppend strTextDumpNA, strTextFileDump
bDumped = True
strTextDumpNA = ""
Else
strTextDumpNA = strTextDumpNA & strTemp
End If
End If 'If bTextFileDumpNA
End If

Next i

End If 'If bUnique
End If 'If coll Is Nothing
End If 'If Len(strBaseNA) = 0

'lCounterNA = lLenStringNA means it is the very last iteration
'another way to do this is doing If lPermut = lCombinationCounterNA
'------------------------------------------------------------------
If bTextFileDumpNA And lCounterNA = lLenStringNA And bDumped = False Then
SaveToTextAppend strTextDumpNA, strTextFileDump
'as these won't be picked up by the lCombinationCounterNA
'--------------------------------------------------------
If lLenStringNA = 2 Then
lCombinationCounterNA = 2
End If
If bShowProgress Then
StatusProgressBar lCombinationCounterNA, lPermutNA, lPermutNA, _
lCombinationCounterNA & "/" & lPermutNA & " - "
End If
End If

End Function


RBS


"obar2" wrote in message
...
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