Results 1 to 4 of 4

Thread: Vba Array Shuffle Giving an Error and Lost Datas!

  1. #1
    VBAX Regular
    Apr 2016

    Vba Array Shuffle Giving an Error and Lost Datas!


    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

    Array Shuffle.xlsm

    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

  2. #2
    Knowledge Base Approver VBAX Wizard
    Apr 2012
    Forget that 'code'

    Look here first:

  3. #3
    Knowledge Base Approver VBAX Wizard
    Oct 2005
    Surrey UK
    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
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  4. #4
    VBAX Regular
    Apr 2016
    Thank you Pascal your code short and working great!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts