Scramble a string with conditions

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
I want to scramble a given string then store the various combinations to a variable or an array based on what you think is cool for my demand. I came across this pieces but they are not exactly what I wanted.




Now this is what I wanna achieve; my code will take a string in the form “AABB” eg 0011, 1122 ,….. Then scramble the string making sure there is no output in the form “AABB” or “BBAA”
So for 0011, the output will be 0101, 1010, 0110, 1001. Then I store this output to a variable or an array as before. The reason being that I will later use the output by splitting the output. But don’t worry about that part that much. I have a way of dealing with things like that. Now all I need is how to get the output and then store them in the aforementioned containers, separated by any suitable list separator. I prefer a comma.


Thanks in advance


Code:
Function Helper(s As String, Optional delim As String = ",") As String
    Dim i As Long, n As Long
    Dim t As String, c As String
    Dim A As Variant


    If Memory.exists(s) Then
        Helper = Memory(s)
        Exit Function
    End If


    'otherwise:
    'Check Basis Case:


    If Len(s) <= 1 Then
        Helper = s
    Else
        n = Len(s)
        ReDim A(1 To n)
        For i = 1 To n
            c = Mid(s, i, 1)
            t = Replace(s, c, "")
            A(i) = Helper(t, delim)
            A(i) = c & Replace(A(i), delim, delim & c)
        Next i
        Helper = Join(A, delim)
    End If


    'record before returning:


    Memory.Add s, Helper
End Function


Code:
Function scramble(s As String, Optional delim As String = ",") As String
    Set Memory = CreateObject("Scripting.dictionary")
    scramble = Helper(s, delim)
    Set Memory = Nothing
End Function


Code:
Sub Test()
    Dim s As String
    Dim i As Long, n As Long
    Dim A As Variant


    s = "0123"
    A = Split(scramble(s), ",")
    For i = 0 To UBound(A)
        Cells(i + 1, 1).Value = A(i)
    Next i
End Sub
 
And these two:
Code:
comb = Left(comb, Len(comb) - 1)
comb = Right(comb, Len(comb) - Len(str) - 1)
Could be replaced with:
Code:
comb = Replace(Left(comb, Len(comb) - 1), str & ",", "")
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Alright.

Very comprehensive.

I am gradually updating my Intel:)
 
Upvote 0
And these two:
Code:
comb = Left(comb, Len(comb) - 1)
comb = Right(comb, Len(comb) - Len(str) - 1)
Could be replaced with:
Code:
comb = Replace(Left(comb, Len(comb) - 1), str & ",", "")

The code is return only one scrambled item after I updated the versions of code you suggested I replace.

Even after I returned to original it's still returning just one
 
Upvote 0
The code just worked again mysteriously.

I was then using the i variable as Long. Could that be a reason?
 
Upvote 0
Code:
Sub Set_String()
Dim com$, ray As Variant, i%, comb$
Dim str$: str = "ABCD"
com = Get_Comb("", "", str)
ray = Remove_Dup(Split(com, ","))
For i = LBound(ray) To UBound(ray) - 1
    comb = comb & ray(i) & ","
Next
comb = Left(comb, Len(comb) - 1)
comb = Right(comb, Len(comb) - Len(str) - 1)
End Sub


Function Get_Comb(comb As String, s1 As String, s2 As String)
Dim i%, sLen%
sLen = Len(s2)
If sLen < 2 Then
    comb = comb & s1 & s2 & ","
Else
    For i = 1 To sLen
        Call Get_Comb(comb, s1 + Mid(s2, i, 1), Left(s2, i - 1) + Right(s2, sLen - i))
    Next
End If
Get_Comb = comb
End Function


Function Remove_Dup(ray As Variant) As Variant
Dim i%, d As Object
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(ray) To UBound(ray)
    If IsMissing(ray(i)) = False Then d.Item(ray(i)) = 1
Next
Remove_Dup = d.Keys
End Function


So I tried to store the items in a vertical list by doing:

Code:
[COLOR=#333333]Code:[/COLOR]
Sub Set_String()
Dim com$, ray As Variant, i%, comb$
Dim str$: str = "ABCD"
com = Get_Comb("", "", str)
ray = Remove_Dup(Split(com, ","))
For i = LBound(ray) To UBound(ray) - 1
    [COLOR="#FF0000"][B]comb = comb & " " & i  + 1 & " " & ray(i) &[/B][/COLOR] [COLOR="#FF0000"][I][B]vbCr[/B][/I][/COLOR]
Next
comb = Left(comb, Len(comb) - 1)
comb = Right(comb, Len(comb) - Len(str) - 1)
End Sub


Function Get_Comb(comb As String, s1 As String, s2 As String)
Dim i%, sLen%
sLen = Len(s2)
If sLen < 2 Then
    comb = comb & s1 & s2 & ","
Else
    For i = 1 To sLen
        Call Get_Comb(comb, s1 + Mid(s2, i, 1), Left(s2, i - 1) + Right(s2, sLen - i))
    Next
End If
Get_Comb = comb
End Function


Function Remove_Dup(ray As Variant) As Variant
Dim i%, d As Object
Set d = CreateObject("Scripting.Dictionary")
For i = LBound(ray) To UBound(ray)
    If IsMissing(ray(i)) = False Then d.Item(ray(i)) = 1
Next
Remove_Dup = d.Keys
End Function

But the numbering is not looking good. Can someone help fix it for me?
 
Upvote 0
Code:
Sub Set_String()
Dim com$, ray As Variant, i%, comb$
Dim str$: str = "ABBA"
com = Get_Comb("", "", str)
ray = Remove_Dup(Split(com, ","))
For i = 1 To UBound(ray) - 1
    comb = comb & " " & i & " " & ray(i) & vbCrLf
Next
End Sub
 
Upvote 0
Code:
Sub Set_String()
Dim com$, ray As Variant, i%, comb$
Dim str$: str = "ABBA"
com = Get_Comb("", "", str)
ray = Remove_Dup(Split(com, ","))
For i = 1 To UBound(ray) - 1
    comb = comb & " " & i & " " & ray(i) & vbCrLf
Next
End Sub

Wow!!!

This is unbelievable. Why did the vbcr give me some issues but not the vbcrlf ?
 
Upvote 0

Forum statistics

Threads
1,223,248
Messages
6,171,027
Members
452,374
Latest member
keccles

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top