Scramble a number

R

RobN

I have a 6 digit number (1-6) and no number is repeated. Is there a formula
or other VBA function that will permutate that number (ie scramble or
interchange the digits), either once off or, preferably, rearrange them in
every possible way.

Rob
 
J

Jim Cone

Well, I just happen to have one...
'---------------------------
' Apr 14, 2002 - Created - Jim Cone - Portland, Oregon USA
' Scrambles the order of the data in a single-cell.
' If second argument evaluates to True, then scrambles each time sheet is calculated.
' Apr 27, 2002 - Removed check for length of Everytime variable as causing error.
' If user text is nothing then provide message. Added error handler.
' Apr 20, 2003 - Made all arguments optional and modified code accordingly.
' Nov 02, 2003 - Simplified Application.Volatile. Added check for user entry error.
' Sep 01, 2006 - Moved TypeName(UserText) line above Application.Volatile.
' Dec 13, 2008 - Changed concept. Now each word is individually scrambled instead
' of scrambling the entire string as a unit. Calls CountIn function.
Function SCRAMBLE(Optional ByRef UserText As Variant, _
Optional ByRef Everytime As Variant) As String
On Error GoTo Scorched
Dim i As Long
Dim j As Long
Dim Num As Long
Dim SpaceCount As Long
Dim NewPosition As Long
Dim Temp As String
Dim strWord As String

If IsMissing(UserText) Then
SCRAMBLE = "No data"
Exit Function
ElseIf IsError(UserText) Then
'No quotes automatically generates an error from the worksheet.
SCRAMBLE = "Error - try adding quote marks around your entry."
Exit Function
ElseIf TypeName(UserText) = "Range" Then
UserText = UserText(1).Value
End If
Application.Volatile (Not IsMissing(Everytime))
UserText = Application.Trim(UserText)

If Len(UserText) > 0 Then
SpaceCount = COUNTIN(UserText, " ")
For i = 1 To SpaceCount + 1 'number of words in text
strWord = ExtractString(UserText, i, " ")
Num = Len(strWord)
Randomize
For j = 1 To Num
If Num = 1 Then
Exit For
Else
Temp = Mid$(strWord, j, 1)
'CLng rounds, so could exceed length of text
NewPosition = Int(Num * Rnd + 1)
Mid$(strWord, j, 1) = Mid$(strWord, NewPosition, 1)
Mid$(strWord, NewPosition, 1) = Temp
End If
Next
SCRAMBLE = SCRAMBLE & " " & strWord
Temp = vbNullString
Next ' i
SCRAMBLE = VBA.Trim$(SCRAMBLE)
Else
SCRAMBLE = "No data" 'Can result from entering ""
End If
Exit Function
Scorched:
SCRAMBLE = "Error " & Err.Number
End Function
'--------------

'Returns the number of times strChar appears in InputText
'Called by Scramble function. Jim Cone - Portland, Oregon USA
'Nov 09, 2004 - Added "\ Len(strChar)" code to handle delimiters > 1 character.
'Dec 13, 2008 - Change InputText to Variant from String so as to work with Scramble function.
Function COUNTIN(ByRef InputText As Variant, ByRef strChars As String) As Long
On Error GoTo LostCount
If Len(strChars) Then
COUNTIN = (Len(InputText) - Len(Application.Substitute(InputText, _
strChars, vbNullString))) \ Len(strChars)
End If
Exit Function
LostCount:
Beep
COUNTIN = 0
End Function
--
Jim Cone
Portland, Oregon USA



"RobN" <[email protected]>
wrote in message
I have a 6 digit number (1-6) and no number is repeated. Is there a formula
or other VBA function that will permutate that number (ie scramble or
interchange the digits), either once off or, preferably, rearrange them in
every possible way.
Rob
 
J

Jim Cone

MORE INFO...
The function, as written calls the ExtractString function which I forgot to post.
The missing function enables SCRAMBLE to used in xl97.
The function is not needed(for later xl versions), if you just replace the following four lines of code...
'---
If Len(UserText) > 0 Then
SpaceCount = COUNTIN(UserText, " ")
For i = 1 To SpaceCount + 1 'number of words in text
strWord = ExtractString(UserText, i, " ")

With...

If Len(UserText) > 0 Then
SpaceCount = COUNTIN(UserText, " ")
For i = 0 To SpaceCount
strWord = VBA.Split(UserText, " ")(i)
 
R

RobN

Hi Jim,

I'm using Vs2007

Can't get this to work even with the modification. Always goes to:
SCRAMBLE = "No data"
Exit Function

I'm not too cluey wuth this sort of stuff, but the code you sent seems to be
for text, not numbers, or doesn't that matter. (Or, don't I know what I'm
talking about? - the more likely option!)

Furthermore, in what cell do I need to put the number?

Rob
 
M

Mike H

Hi,

Maybe a little simpler. ALT+F11 to open VB editor. Right click
'ThisWorkbook' and insert module and paste the code below in.

call with
=Mix(A1)

or

=Mix(123456) or =Mix(abcde)

Function Mix(Utext As Variant) As String
Dim i As Long
Dim NewPos As Long
Dim Temp As String
For i = 1 To Len(Utext)
Temp = Mid$(Utext, i, 1)
NewPos = Int(Len(Utext) * Rnd + 1)
Mid$(Utext, i, 1) = Mid$(Utext, NewPos, 1)
Mid$(Utext, NewPos, 1) = Temp
Next
Mix = Utext
End Function

Mike

RobN said:
Hi Jim,

I'm using Vs2007

Can't get this to work even with the modification. Always goes to:
SCRAMBLE = "No data"
Exit Function

I'm not too cluey wuth this sort of stuff, but the code you sent seems to be
for text, not numbers, or doesn't that matter. (Or, don't I know what I'm
talking about? - the more likely option!)

Furthermore, in what cell do I need to put the number?

Rob
Click to expand...
 
R

RobN

Hi Mike,

Thanks for that. Works perfectly for a single scramble.
I found some code on the internet that will list every possible permutation
, so I'm happy.

Rob


Mike H said:
Hi,

Maybe a little simpler. ALT+F11 to open VB editor. Right click
'ThisWorkbook' and insert module and paste the code below in.

call with
=Mix(A1)

or

=Mix(123456) or =Mix(abcde)

Function Mix(Utext As Variant) As String
Dim i As Long
Dim NewPos As Long
Dim Temp As String
For i = 1 To Len(Utext)
Temp = Mid$(Utext, i, 1)
NewPos = Int(Len(Utext) * Rnd + 1)
Mid$(Utext, i, 1) = Mid$(Utext, NewPos, 1)
Mid$(Utext, NewPos, 1) = Temp
Next
Mix = Utext
End Function

Mike
Click to expand...
 
C

Chip Pearson

At www.cpearson.com/Excel/ShuffleArray.aspx I have a function called
ShuffleArray which scrambles an array in random order. You can wrap
this up in a function to randomly scramble a string of characters:

Function ShuffleChars(S As String) As Variant
' Reorders characters of S in random order.
' Calls ShuffleArray.
Dim Arr() As Variant
Dim N As Long
Dim T As String

If Len(S) = 0 Then
ShuffleChars = CVErr(xlErrValue)
Exit Function
End If
ReDim Arr(1 To Len(S))
For N = 1 To Len(S)
Arr(N) = Mid(S, N, 1)
Next N
Arr = ShuffleArray(Arr)
For N = 1 To UBound(Arr)
T = T & Arr(N)
Next N
ShuffleChars = T
End Function


This calls ShuffleArray, shown here:

Function ShuffleArray(InArray() As Variant) As Variant()
Dim N As Long
Dim L As Long
Dim Temp As Variant
Dim J As Long
Dim Arr() As Variant

Randomize
L = UBound(InArray) - LBound(InArray) + 1
ReDim Arr(LBound(InArray) To UBound(InArray))
For N = LBound(InArray) To UBound(InArray)
Arr(N) = InArray(N)
Next N
For N = LBound(InArray) To UBound(InArray)
J = Int((UBound(InArray) - LBound(InArray) + 1) * _
Rnd + LBound(InArray))
If N <> J Then
Temp = Arr(N)
Arr(N) = Arr(J)
Arr(J) = Temp
End If
Next N
ShuffleArray = Arr
End Function


You can call ShuffleChars from a worksheet cell with

=ShuffleChars(A1) where A1 contains the characters to scramble.

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)
 
R

RobN

Thanks Chip.

Rob

Chip Pearson said:
At www.cpearson.com/Excel/ShuffleArray.aspx I have a function called
ShuffleArray which scrambles an array in random order. You can wrap
this up in a function to randomly scramble a string of characters:

Function ShuffleChars(S As String) As Variant
' Reorders characters of S in random order.
' Calls ShuffleArray.
Dim Arr() As Variant
Dim N As Long
Dim T As String

If Len(S) = 0 Then
ShuffleChars = CVErr(xlErrValue)
Exit Function
End If
ReDim Arr(1 To Len(S))
For N = 1 To Len(S)
Arr(N) = Mid(S, N, 1)
Next N
Arr = ShuffleArray(Arr)
For N = 1 To UBound(Arr)
T = T & Arr(N)
Next N
ShuffleChars = T
End Function


This calls ShuffleArray, shown here:

Function ShuffleArray(InArray() As Variant) As Variant()
Dim N As Long
Dim L As Long
Dim Temp As Variant
Dim J As Long
Dim Arr() As Variant

Randomize
L = UBound(InArray) - LBound(InArray) + 1
ReDim Arr(LBound(InArray) To UBound(InArray))
For N = LBound(InArray) To UBound(InArray)
Arr(N) = InArray(N)
Next N
For N = LBound(InArray) To UBound(InArray)
J = Int((UBound(InArray) - LBound(InArray) + 1) * _
Rnd + LBound(InArray))
If N <> J Then
Temp = Arr(N)
Arr(N) = Arr(J)
Arr(J) = Temp
End If
Next N
ShuffleArray = Arr
End Function


You can call ShuffleChars from a worksheet cell with

=ShuffleChars(A1) where A1 contains the characters to scramble.

Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)
Click to expand...
 
J

Jim

My question concerns a similar issue regarding the PERMUTATION command.
Specifically is it possible to use this command with multiple "R's?" The
first argument is N and represents the number of choices. The second argument
represents the types of choices or groupings. In some cases the R can have
several values, such as R1=4, R2=3. In these cases I have found I can only
compute the permutation by using the mathematical formula.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Loop 1
Extracting 7 digit number from alphanumeric string 10
List number of permutations for text nums 20
change a decimal number to a whole number 5
How do I stop Excel from dropping leading zeros? 9
How add a digit to front of number in each cell in excexl column 1
need a formula to find "*" in s string and multiply by preceding andfollowing values 5
enter a number if equal to another number 4

Top