Shuffle words to appear to be random

[funguy]

Shuffle words to appear to be random

Hi , I'm trying to make some data look a little more 'human' by shuffling around some words/phrases. Each cell will always contain 4 words/phrases. I'd like to shuffle them to make them look random. The comma needs to be the deliminator because sometimes the term might be a 2 or 3 words phrase or term (like 'dark forest green' for example). I figure the easiest way is to split each word/phrase into it's own column/cell, then reconstruct them using a varied formula to create the shuffle effect ? I'm very open to trying a macro if some genius out there knows one. I use macros but cannot write them, so figured I'd try a formula approach first. I could not attach a sample worksheet, so I added it to a wetransfer link, and also a quick example below. Any ideas would be much appreciated.

- THANK YOU

example file
https://we.tl/4ta1kJKDOt


Column A (given data): --- Column B (desired results):
red, blue, green, yellow --- blue, red, yellow, green
red, blue, green, yellow --- green, blue, red, yellow
red, blue, green, yellow --- red, yellow, green, blue
red, blue, green, yellow --- yellow, green, red, blue

 

[WarPigl3t]

I think the easiest way is with a macro. The macro logic will read as follows. The first row with your color data will be in row 2 because maybe you have headers. Change it to row 1 if you don't. For each row in column A all the way down to the last row, split the data into an array using a comma as the delimiter. Once split, send the split array to a function which shuffles the array and returns the new array to the original macro subroutine. Combine each element in the array into one string value separated by commas. Output the string into column B. Do this for all rows.

Sub myMacro()
     firstRow = 2
     lastRow = Range("A" & Rows.Count).End(xlUp).Row
     r = firstRow
     Do Until r > lastRow
          valueA = Range("A" & r).Value
          splitA = Split(valueA, ", ")
          newArray = ShuffleArray(splitA)
          valueB = ""
          For Each element In newArray
               valueB = valueB & ", " & element
          Next element
          valueB = Right(valueB, Len(valueB) - 2)
          Range("B" & r).Value = valueB
          r = r + 1
     Loop
End Sub

Pulled this shuffle array code from http://www.cpearson.com/excel/ShuffleArray.aspx

Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N 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 = CLng(((UBound(InArray) - N) * Rnd) + N)
        Temp = Arr(N)
        Arr(N) = ARr(J)
        Arr(J) = Temp
    Next N
    ShuffleArray = Arr
End Function

 

[Trebor76]

Hi there,

My results are different as by nature they're random but I think this is what you're after:

Option Explicit
Sub Macro1()

    Dim rngMyCell As Range
    Dim strTextArray() As String
    Dim i As Integer
    Dim dblMyNum As Double
    Dim clnMyNumbers As New Collection
    Dim strMyShuffledText As String
    
    Application.ScreenUpdating = False
    
    For Each rngMyCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) 'Range A2:A [last row]
        strTextArray() = Split(rngMyCell, ",")
        Randomize
        Do Until i = 4 'Randomize numbers 1 to 4 inclusive
            dblMyNum = Int((4 - 1 + 1) * Rnd + 1) 'http://www.techonthenet.com/excel/formulas/rnd.php
            On Error Resume Next
                clnMyNumbers.Add Item:=dblMyNum, Key:=CStr(dblMyNum)
                If Err.Number = 0 Then
                    If strMyShuffledText = "" Then
                        strMyShuffledText = Trim(strTextArray(dblMyNum - 1))
                    Else
                        strMyShuffledText = strMyShuffledText & ", " & Trim(strTextArray(dblMyNum - 1))
                    End If
                    i = i + 1
                Else
                    Err.Clear
                End If
            On Error GoTo 0
        Loop
        'Output shuffled text
        rngMyCell.Offset(0, 1) = strMyShuffledText
        'Initialise variables
        i = 0
        Set clnMyNumbers = Nothing
        strMyShuffledText = ""
    Next rngMyCell
    
    Application.ScreenUpdating = False

End Sub

Regards,

Robert

 

[funguy]

Thank you both ! these work great !

 

[Peter_SSs]

If you want to try another one, here's a shorter one that I think also does what you want.

Sub ShufflePhrases()
  Dim a As Variant, b As Variant, phrases As Variant
  Dim i As Long, j As Long, k As Long
  
  Randomize
  a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    phrases = Split(a(i, 1), ", ")
    For j = 0 To UBound(phrases)
      k = Int(Rnd() * (UBound(phrases) - j))
      b(i, 1) = b(i, 1) & ", " & phrases(k)
      phrases(k) = phrases(UBound(phrases) - j)
    Next j
    b(i, 1) = Mid(b(i, 1), 3)
  Next i
  Range("B2").Resize(UBound(b)).Value = b
End Sub