Vba Array Shuffle Giving an Error and Lost Datas!

Hello!

I'm trying to adapt a code I found on the internet. This code works like this.

-Each Excel cell consist of blank cells, special characters, integer and strings.
-first finds the last not empty cell. It then loop through all the cells.
-each row consists of dynamic cells. All cells that are full are transferred to the array by entering the loop.
-array is transferred to the ready code and shuffle and rewrite to cells.
-I'm getting this error here (Run-time error '9': Subscript out of range)
and somehow some data is lost

Here my code and excel file

:arrowr: Attachment 28409 :arrowl:

Thank you

Code:

---


Function Resample(data_vector() As Variant) As Variant()
    Dim shuffled_vector() As Variant
    shuffled_vector = data_vector
    Dim i As Long
    For i = UBound(shuffled_vector) To LBound(shuffled_vector) Step -1
        Dim t As Variant
        t = shuffled_vector(i)
        Dim j As Long
        j = Application.RandBetween(LBound(shuffled_vector), UBound(shuffled_vector))
        shuffled_vector(i) = shuffled_vector(j)
        shuffled_vector(j) = t

    Next i
    Resample = shuffled_vector
End Function

Sub PopulatingArray()

Dim myArray() As Variant
Dim rng As Range
Dim cell As Range
Dim x As Long

'Last Row
Lr = Cells(Rows.Count, 1).End(xlUp).Row

'Loop Each Row
For i = 1 To Lr
lCol = Cells(i, Columns.Count).End(xlToLeft).Column
Set rng = Range(Cells(i, 2), Cells(i, lCol))

    ReDim myArray(rng.Cells.Count)

'Populate Array
    For Each cell In rng.Cells
        myArray(x) = cell.Value
        Debug.Print myArray(x)
        x = x + 1
    Next cell
   
'call functiion
myArray = Resample(myArray)
rng.Value = myArray
Debug.Print Join(myArray, ",")
Next i
End Sub

---

Forget that 'code'

Look here first: https://www.snb-vba.eu/VBA_Arrays_en.html

Code:

---

Sub PopulatingArray()
Dim i As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
  With Range(Cells(i, 2), Cells(i, Columns.Count).End(xlToLeft))
    .Value = Resample(.Value)
  End With
Next i
End Sub

Function Resample(data_vector)
Dim i As Long, j As Long, t
For i = UBound(data_vector, 2) To LBound(data_vector, 2) Step -1
  j = Application.RandBetween(LBound(data_vector, 2), UBound(data_vector, 2))
  t = data_vector(1, i)
  data_vector(1, i) = data_vector(1, j)
  data_vector(1, j) = t
Next i
Resample = data_vector
End Function

---

Thank you Pascal your code short and working great!