| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
loop each with each string
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
Hi Abar.
Se the following post by Tom Ogilvy which includes code by Myrna Larsen: http://tinyurl.com/37vj5b --- Regards, Norman "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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
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 |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
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 |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
Yes, had a look now at the code from Myrna Larson and it is a bit more
complex, but a lot faster. It will need a bit of re-coding though to make it work like a VBA function without sheet values. 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 |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
One thing with Myrna's code is that you will get duplicates when your
starting sequence contains duplicate characters. 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 |
|
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
You can make it a lot faster by adding a function to
find the next usable loop number: Function GetNextLoopNumber(lNumber As Long, lLength As Long, lPos As Long) As Long Dim i As Long Dim strNumber As String strNumber = CStr(lNumber) For i = lLength To lPos Step -1 Mid$(strNumber, i, 1) = 1 Next If lPos = 1 Then GetNextLoopNumber = lNumber Exit Function End If If Val(Mid$(strNumber, lPos - 1, 1)) < lLength Then Mid$(strNumber, lPos - 1, 1) = Val(Mid$(strNumber, lPos - 1, 1)) + 1 Else If lPos = 2 Then GetNextLoopNumber = lNumber Exit Function End If Mid$(strNumber, lPos - 1, 1) = 1 Mid$(strNumber, lPos - 2, 1) = Val(Mid$(strNumber, lPos - 2, 1)) + 1 End If GetNextLoopNumber = Val(strNumber) - 1 End Function Then the main function will be: 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 = 0 Then Exit For End If If lVal lLen Then i = GetNextLoopNumber(i, lLen, n) 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 Still not as fast though as Myrna's code. 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 |
|
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
And even faster by doing Step 9 in the outer loop.
So: For i = lMin To lMax Step 9 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 |
|
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
OK, forget about the function to find the next loop number:
Function GetUniqueCombinations(strString As String) As Collection Dim i As Long Dim n As Long Dim x As Long Dim z As Long Dim lStep 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 lStep = 9 For i = lMin To lMax Step lStep x = x + 1 'all this can be optimized better '-------------------------------- If x Mod 2 = 0 Then If lStep = 9 Then lStep = 18 Else lStep = 9 End If Else lStep = (12 - lLen) * 9 End If str1 = "" str2 = "" For n = 1 To lLen lVal = Val(Mid$(CStr(i), n, 1)) If lVal = 0 Or lVal lLen 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 "RB Smissaert" wrote in message ... And even faster by doing Step 9 in the outer loop. So: For i = lMin To lMax Step 9 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 |
|
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
This is better, but not tested with a string of more than 9 characters.
I am sure there must be a much faster algorithm for this, other than the one by Myrna Larsen. Function GetUniqueCombinations(strString As String) As Collection Dim i As Long Dim n As Long Dim x As Long Dim y As Long Dim z As Long Dim lStep As Long Dim lLen As Long Dim lMin As Long Dim lMax As Long Dim lVal As Long Dim str1 As String Dim str2 As String Dim strNumber As String lLen = Len(strString) 'get the minimum and maximum of the outer loop '--------------------------------------------- For n = 1 To lLen 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 lStep = 9 For i = lMin To lMax Step lStep x = x + 1 'all this can be optimized better '-------------------------------- If x Mod 2 = 0 Then lStep = 9 Else y = y + 1 If y Mod 3 = 0 Then lStep = ((11 - lLen) * 10 + 11 - lLen) * 9 Else lStep = (12 - lLen) * 9 End If End If str1 = "" str2 = "" strNumber = CStr(i) For n = 1 To lLen lVal = Val(Mid$(strNumber, n, 1)) If lVal = 0 Or lVal lLen Then Exit For End If If n = 1 Then str1 = lVal str2 = Mid$(strString, lVal, 1) Else 'to avoid taking the same character of the string more than once '--------------------------------------------------------------- If InStr(1, str1, lVal, vbBinaryCompare) = 0 Then str1 = str1 & lVal str2 = str2 & Mid$(strString, lVal, 1) 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 "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 |
|
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
One more refinement to make it faster:
Function UniqueCharsInString(strString As String) As Long Dim i As Long Dim strChar As String Dim coll As Collection Set coll = New Collection On Error Resume Next For i = 1 To Len(strString) strChar = Mid$(strString, i, 1) coll.Add strChar, strChar Next i UniqueCharsInString = coll.Count End Function Function GetUniqueCombinations(strString As String) As Collection Dim i As Long Dim n As Long Dim x As Long Dim y As Long Dim z As Long Dim lStep As Long Dim lLen As Long Dim lMin As Long Dim lMax As Long Dim lVal As Long Dim lUnique As Long Dim str1 As String Dim str2 As String Dim strNumber As String lLen = Len(strString) lUnique = UniqueCharsInString(strString) 'get the minimum and maximum of the outer loop '--------------------------------------------- For n = 1 To lLen 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 lStep = 9 For i = lMin To lMax Step lStep x = x + 1 'all this can be optimized better '-------------------------------- If x Mod 2 = 0 Then lStep = 9 Else y = y + 1 If y Mod 3 = 0 Then lStep = ((11 - lUnique) * 10 + 11 - lUnique) * 9 Else lStep = (12 - lUnique) * 9 End If End If str1 = "" str2 = "" strNumber = CStr(i) For n = 1 To lLen lVal = Val(Mid$(strNumber, n, 1)) If lVal = 0 Or lVal lLen Then Exit For End If If n = 1 Then str1 = lVal str2 = Mid$(strString, lVal, 1) Else 'to avoid taking the same character of the string more than once '--------------------------------------------------------------- If InStr(1, str1, lVal, vbBinaryCompare) = 0 Then str1 = str1 & lVal str2 = str2 & Mid$(strString, lVal, 1) 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 "RB Smissaert" wrote in message ... This is better, but not tested with a string of more than 9 characters. I am sure there must be a much faster algorithm for this, other than the one by Myrna Larsen. Function GetUniqueCombinations(strString As String) As Collection Dim i As Long Dim n As Long Dim x As Long Dim y As Long Dim z As Long Dim lStep As Long Dim lLen As Long Dim lMin As Long Dim lMax As Long Dim lVal As Long Dim str1 As String Dim str2 As String Dim strNumber As String lLen = Len(strString) 'get the minimum and maximum of the outer loop '--------------------------------------------- For n = 1 To lLen 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 lStep = 9 For i = lMin To lMax Step lStep x = x + 1 'all this can be optimized better '-------------------------------- If x Mod 2 = 0 Then lStep = 9 Else y = y + 1 If y Mod 3 = 0 Then lStep = ((11 - lLen) * 10 + 11 - lLen) * 9 Else lStep = (12 - lLen) * 9 End If End If str1 = "" str2 = "" strNumber = CStr(i) For n = 1 To lLen lVal = Val(Mid$(strNumber, n, 1)) If lVal = 0 Or lVal lLen Then Exit For End If If n = 1 Then str1 = lVal str2 = Mid$(strString, lVal, 1) Else 'to avoid taking the same character of the string more than once '--------------------------------------------------------------- If InStr(1, str1, lVal, vbBinaryCompare) = 0 Then str1 = str1 & lVal str2 = str2 & Mid$(strString, lVal, 1) 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 "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 |
|
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
OK, forget about the previous effort, this is a lot faster and cleaner.
Adapted from code found at: http://www.codeguru.com/vb/gen/vb_mi...hp/c5607/#more Function PermuteString(strString As String, _ Optional strSeparator As String, _ Optional bUnique As Boolean, _ Optional coll As Collection, _ Optional bStringResult As Boolean, _ Optional strBase As String, _ Optional lLenString As Long, _ Optional lLenSeparator 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 the last 3 args: strBase, lLenString or lLenSeparator '---------------------------------------------------------------------------- Dim i As Long Dim strTemp As String Dim strTemp2 As String If lLenString = 0 Then lLenString = Len(strString) lLenSeparator = Len(strSeparator) End If If Len(strString) = 1 Then PermuteString = strBase & 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(strBase) = 0 Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ bUnique, _ coll, _ bStringResult, _ Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If bStringResult Then PermuteString = PermuteString & strTemp End If Next Else 'If Len(strBase) = 0 If coll Is Nothing Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ bUnique, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If bStringResult Then PermuteString = PermuteString & strTemp End If Next i Else 'If coll Is Nothing If bUnique Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ True, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If Len(strTemp) = lLenString + lLenSeparator Then strTemp2 = Left$(strTemp, lLenString) coll.Add strTemp2, strTemp2 End If If bStringResult Then PermuteString = PermuteString & strTemp End If Next i Else 'If bUnique For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ False, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If Len(strTemp) = lLenString + lLenSeparator Then coll.Add Left$(strTemp, lLenString) End If If bStringResult Then PermuteString = PermuteString & strTemp End If Next i End If 'If bUnique End If 'If coll Is Nothing End If 'If Len(strBase) = 0 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 |
|
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
Forgot to post the helper function:
Function ReturnAllBut(strString As String, _ lOmit As Long) As String Dim i As Long For i = 1 To Len(strString) If i < lOmit Then ReturnAllBut = ReturnAllBut & Mid$(strString, i, 1) End If Next End Function RBS "RB Smissaert" wrote in message ... OK, forget about the previous effort, this is a lot faster and cleaner. Adapted from code found at: http://www.codeguru.com/vb/gen/vb_mi...hp/c5607/#more Function PermuteString(strString As String, _ Optional strSeparator As String, _ Optional bUnique As Boolean, _ Optional coll As Collection, _ Optional bStringResult As Boolean, _ Optional strBase As String, _ Optional lLenString As Long, _ Optional lLenSeparator 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 the last 3 args: strBase, lLenString or lLenSeparator '---------------------------------------------------------------------------- Dim i As Long Dim strTemp As String Dim strTemp2 As String If lLenString = 0 Then lLenString = Len(strString) lLenSeparator = Len(strSeparator) End If If Len(strString) = 1 Then PermuteString = strBase & 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(strBase) = 0 Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ bUnique, _ coll, _ bStringResult, _ Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If bStringResult Then PermuteString = PermuteString & strTemp End If Next Else 'If Len(strBase) = 0 If coll Is Nothing Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ bUnique, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If bStringResult Then PermuteString = PermuteString & strTemp End If Next i Else 'If coll Is Nothing If bUnique Then For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ True, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If Len(strTemp) = lLenString + lLenSeparator Then strTemp2 = Left$(strTemp, lLenString) coll.Add strTemp2, strTemp2 End If If bStringResult Then PermuteString = PermuteString & strTemp End If Next i Else 'If bUnique For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ False, _ coll, _ bStringResult, _ strBase & Mid$(strString, i, 1), _ lLenString, _ lLenSeparator) If Len(strTemp) = lLenString + lLenSeparator Then coll.Add Left$(strTemp, lLenString) End If If bStringResult Then PermuteString = PermuteString & strTemp End If Next i End If 'If bUnique End If 'If coll Is Nothing End If 'If Len(strBase) = 0 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 |
|
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
As there will be problems (out of memory) with string of more than 9
characters, I added the option to dump to text file. Also added the option to count the produced number of combinations. 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 bTextFileDumpNA As Boolean, _ 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 lCombinationCounterNA 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 8 arguments: 'bTextFileDumpNA 'strBaseNA 'lLenStringNA 'lLenSeparatorNA 'bUniqueCharsNA 'strTextDumpNA 'lCounterNA 'lCombinationCounterNA '---------------------------------------------------------------------------- '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 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, _ bTextFileDumpNA, _ Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 strTemp2 = Left$(strTemp, lLenStringNA) coll.Add strTemp2, strTemp2 If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If End If Next i Else 'If bUnique For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ False, _ coll, _ bStringResult, _ strTextFileDump, _ lDumpThreshold, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 coll.Add Left$(strTemp, lLenStringNA) If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If 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 '------------------------------------------------------------- If bTextFileDumpNA And lCounterNA = lLenStringNA And bDumped = False Then SaveToTextAppend strTextDumpNA, strTextFileDump End If End Function Sub SaveToTextAppend(strText As String, Optional strFullPath As String) Dim hFile As Long If Len(strFullPath) = 0 Then strFullPath = ThisWorkbook.Path & "\Dump.txt" End If hFile = FreeFile Open strFullPath For Append As hFile Print #hFile, strText Close #hFile End Sub Function bFileExists(ByVal sFile As String) As Boolean Dim lAttr As Long On Error Resume Next lAttr = GetAttr(sFile) bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0) On Error GoTo 0 End Function I think that will be it now. 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 |
|
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
One little alteration to avoid blank lines in the text dump.
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 bTextFileDumpNA As Boolean, _ 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 lCombinationCounterNA 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 8 arguments: 'bTextFileDumpNA 'strBaseNA 'lLenStringNA 'lLenSeparatorNA 'bUniqueCharsNA 'strTextDumpNA 'lCounterNA 'lCombinationCounterNA '---------------------------------------------------------------------------- '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 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, _ bTextFileDumpNA, _ Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 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 '------------------------------------------------------------- If bTextFileDumpNA And lCounterNA = lLenStringNA And bDumped = False Then SaveToTextAppend strTextDumpNA, strTextFileDump End If End Function RBS "RB Smissaert" wrote in message ... As there will be problems (out of memory) with string of more than 9 characters, I added the option to dump to text file. Also added the option to count the produced number of combinations. 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 bTextFileDumpNA As Boolean, _ 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 lCombinationCounterNA 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 8 arguments: 'bTextFileDumpNA 'strBaseNA 'lLenStringNA 'lLenSeparatorNA 'bUniqueCharsNA 'strTextDumpNA 'lCounterNA 'lCombinationCounterNA '---------------------------------------------------------------------------- '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 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, _ bTextFileDumpNA, _ Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If 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, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 strTemp2 = Left$(strTemp, lLenStringNA) coll.Add strTemp2, strTemp2 If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If End If Next i Else 'If bUnique For i = 1 To Len(strString) strTemp = PermuteString(ReturnAllBut(strString, i), _ strSeparator, _ False, _ coll, _ bStringResult, _ strTextFileDump, _ lDumpThreshold, _ bTextFileDumpNA, _ strBaseNA & Mid$(strString, i, 1), _ lLenStringNA, _ lLenSeparatorNA, _ bUniqueCharsNA, _ strTextDumpNA, _ lCounterNA, _ lCombinationCounterNA) If bStringResult Then PermuteString = PermuteString & strTemp End If If Len(strTemp) = lLenStringNA + lLenSeparatorNA Then lCombinationCounterNA = lCombinationCounterNA + 1 coll.Add Left$(strTemp, lLenStringNA) If bTextFileDumpNA Then strTextDumpNA = strTextDumpNA & strTemp If Len(strTextDumpNA) lDumpThreshold Then SaveToTextAppend strTextDumpNA, strTextFileDump bDumped = True strTextDumpNA = "" End If End If 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 '------------------------------------------------------------- If bTextFileDumpNA And lCounterNA = lLenStringNA And bDumped = False Then SaveToTextAppend strTextDumpNA, strTextFileDump End If End Function Sub SaveToTextAppend(strText As String, Optional strFullPath As String) Dim hFile As Long If Len(strFullPath) = 0 Then strFullPath = ThisWorkbook.Path & "\Dump.txt" End If hFile = FreeFile Open strFullPath For Append As hFile Print #hFile, strText Close #hFile End Sub Function bFileExists(ByVal sFile As String) As Boolean Dim lAttr As Long On Error Resume Next lAttr = GetAttr(sFile) bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0) On Error GoTo 0 End Function I think that will be it now. 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 |
|
#17
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
loop each with each string
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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Do Loop or use End iF for search string | Excel Discussion (Misc queries) | |||
| Loop through range and add each cell contents to a string | Excel Programming | |||
| Loop through range of cells, string search, take action | Excel Programming | |||
| ReDim string in loop | Excel Programming | |||
| Advancing outer Loop Based on criteria of inner loop | Excel Programming | |||
Linear Mode
