Vba Array Shuffle Giving an Error and Lost Datas!

[icemail]

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: 28409 :arrowl:

Thank you



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

[snb]

Forget that 'code'

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

[p45cal]

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

[icemail]

Thank you Pascal your code short and working great!