Randomly change the value containing data in the array

[MyHanhCB]

Hello everyone in the forum.
I have the following code that randomly changes the value contained in an array. But I think it's still not optimized.
Looking forward to more optimal solutions from professional programmers to consult and learn more about vba excel. Thank you very much.

Function ShuffleArray(arr As Variant) As Variant
Dim j%, i%, randomIndex%, dict As New Dictionary, myarr As Variant
         Randomize
        ReDim myarr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
            For j = LBound(arr, 1) To UBound(arr, 1)
            randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
        If Not dict.Exists(randomIndex) Then
                   dict.Add randomIndex, randomIndex
tiepRndIx:
    For i = LBound(arr, 2) To UBound(arr, 2)
        myarr(j, i) = arr(randomIndex, i)
    Next i
        Else
tiepRndIx1:
            randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
            If Not dict.Exists(randomIndex) Then
            dict.Add randomIndex, randomIndex
            GoTo tiepRndIx
            Else
            GoTo tiepRndIx1
            End If
         End If
            Next j
ShuffleArray = myarr
End Function

 

[Dan_W]

The first thing that jumps out at me is your indentation - it makes it very difficult to follow.
The second thing that jumps out me is that you've used GoTo, which you really should avoid, especially here where you are GoToing a part of a conditional statement. But this then reveals that you seem to be writing the same code twice.
So there a number of optimisations you can make to this, but I think it would help you if you could set out (maybe in pseudocode) what the logic of the code is - because at present, it's a bit muddled.

 

[Herakles]

This procedure sorts each column of the array in turn, independantly of the other columns, and based upon a unique
randomly generated decimal which has the effect of changing each value for that of another.

It creates a temporary worksheet to do this it which it then deletes at the end.

Public Function fncShuffleArray(arr() As Variant) As Variant
Dim rngColumn As Range
Dim Ws As Worksheet

    Set Ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    
    Ws.Name = Format(Now(), "ddmmyyyy") & Format(Now(), "hhmmss")
    
    Ws.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        
    For Each rngColumn In Ws.Range("A1").CurrentRegion.Columns
        rngColumn.Offset(0, 1).EntireColumn.Insert
        rngColumn.Offset(0, 1).Formula = "=RAND()"
        rngColumn.Offset(0, 1).Value = rngColumn.Offset(0, 1).Value
        Ws.Sort.SortFields.Clear
        Ws.Sort.SortFields.Add rngColumn.Offset(0, 1), xlSortOnValues, xlAscending
        With Ws.Sort
            .SetRange rngColumn.Resize(rngColumn.Rows.Count, 2)
            .Apply
        End With
        rngColumn.Offset(0, 1).EntireColumn.Delete
    Next rngColumn

    arr = Ws.Range("A1").CurrentRegion
    
    Application.DisplayAlerts = False
    Ws.Delete
    Application.DisplayAlerts = True
    
    fncRandomOrderColumns = arr

End Function

 

[Fluff]

Another option

Function ShuffleArray(arr As Variant) As Variant
   Dim j As Long, i As Long, randomIndex As Long
   Dim dict As Object
   Dim myarr As Variant
   
   Set dict = CreateObject("scripting.dictionary")
   ReDim myarr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
   Randomize
   
   For j = LBound(arr, 1) To UBound(arr, 1)
      randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
      Do While dict.Exists(randomIndex)
         randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
      Loop
      dict.Add randomIndex, Nothing
      For i = LBound(arr, 2) To UBound(arr, 2)
         myarr(j, i) = arr(randomIndex, i)
      Next i
   Next j
   ShuffleArray = myarr
End Function

 

[MyHanhCB]

The first thing that jumps out at me is your indentation - it makes it very difficult to follow.
The second thing that jumps out me is that you've used GoTo, which you really should avoid, especially here where you are GoToing a part of a conditional statement. But this then reveals that you seem to be writing the same code twice.
So there a number of optimisations you can make to this, but I think it would help you if you could set out (maybe in pseudocode) what the logic of the code is - because at present, it's a bit muddled.

yes, thanks for the comment.

 

[MyHanhCB]

This procedure sorts each column of the array in turn, independantly of the other columns, and based upon a unique
randomly generated decimal which has the effect of changing each value for that of another.

It creates a temporary worksheet to do this it which it then deletes at the end.

Public Function fncShuffleArray(arr() As Variant) As Variant
Dim rngColumn As Range
Dim Ws As Worksheet

    Set Ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
   
    Ws.Name = Format(Now(), "ddmmyyyy") & Format(Now(), "hhmmss")
   
    Ws.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
       
    For Each rngColumn In Ws.Range("A1").CurrentRegion.Columns
        rngColumn.Offset(0, 1).EntireColumn.Insert
        rngColumn.Offset(0, 1).Formula = "=RAND()"
        rngColumn.Offset(0, 1).Value = rngColumn.Offset(0, 1).Value
        Ws.Sort.SortFields.Clear
        Ws.Sort.SortFields.Add rngColumn.Offset(0, 1), xlSortOnValues, xlAscending
        With Ws.Sort
            .SetRange rngColumn.Resize(rngColumn.Rows.Count, 2)
            .Apply
        End With
        rngColumn.Offset(0, 1).EntireColumn.Delete
    Next rngColumn

    arr = Ws.Range("A1").CurrentRegion
   
    Application.DisplayAlerts = False
    Ws.Delete
    Application.DisplayAlerts = True
   
    fncRandomOrderColumns = arr

End Function

yes, thanks for the suggestion.

 

[MyHanhCB]

Another option

Function ShuffleArray(arr As Variant) As Variant
   Dim j As Long, i As Long, randomIndex As Long
   Dim dict As Object
   Dim myarr As Variant
  
   Set dict = CreateObject("scripting.dictionary")
   ReDim myarr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
   Randomize
  
   For j = LBound(arr, 1) To UBound(arr, 1)
      randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
      Do While dict.Exists(randomIndex)
         randomIndex = Int((UBound(arr, 1) - LBound(arr, 1) + 1) * Rnd + LBound(arr, 1))
      Loop
      dict.Add randomIndex, Nothing
      For i = LBound(arr, 2) To UBound(arr, 2)
         myarr(j, i) = arr(randomIndex, i)
      Next i
   Next j
   ShuffleArray = myarr
End Function

yes, thanks for the solution.

 

[Fluff]

Glad we could help & thanks for the feedback.