'Creating an array and pasting to set cols in VBA

I wanted to try to create an array in VBA and paste it to back into another sheet in the same workbook. I need an array of 50 random integer values, these 50 values need to come from 4 different sources, Source A = 15 values, Source B = 15 Values, Source C = 10 values, Source D = 10 Values. If the array cannot be filled to 15 or 10 by the source, I would like to fill what is left with source A. Here is some of the sample data i have

Sample Data 'This is redundant and can be replicated to create up to 50 entries, but the logic will stem from these entries.
    Name Number      Source
    Bill  123456789  Type A
    Bill  213456789  Type B
    Bill  313456789  Type C
    Bill  413456789  Type D
    ...
    ...       
    ...
    Mary  231234567  Type A
    Mary  231234567  Type B
    Mary  231234567  Type C
    ...
    ...       
    ...
    Tom   234567891  Type A
    ...
    ...       
    ...

Sub RandomNumberGen()
 'Create Arrays for each type of inspections
   Dim TypeAArray() As Variant
   Dim TypeBArray() As Variant
   Dim TypeCArray() As Variant
   Dim TypeDArray() As Variant

 'Set Arrays range
   Dim my_OverRange As Range
   LastRow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
   Set my_TypeARange = Sheets("Sheet2").Range("C2:C" & LastRow)
   ReDim ColumnOverArray(LastRow) 'Re size your array to fit data
   ColumnOverArray = my_TypeARange 'add data to array

 'Create loop to cycle through arrays and gather Random values?
 'This is where im at so far. Im able to create an array and 
 'paste back into excel. Either i need to run a loop to cycle 
 'through or create 3 more arrays and get random values from the 
 'ranges.
   MyTypeARange().Value = MyTypeARange.Random(15)
   MyTypeBRange().Value = Random(15)
   MyTypeCRange().Value = Random(10)
   MyTypeDRange().Value = Random(10)

 'Paste Random Values into sheet

My end result should look something like this.

    Number   Source
    123456789  Type A
    ...
    ...
    ...
    123456789  Type B
    ...
    ...
    ...
    123456789  Type C
    ...
    ...
    ...
    123456789  Type D
    ...
    ...
    ...     


Solution 1:[1]

Please, test the next code. It will randomly extract elements from the ranges (to be larger than 15) in columns "C", "E", "G" and "J" and placed them in the four arrays you used in your code, but differently dimensioned. These four arrays are placed in a jagged array (an array of arrays) and randomly loaded. The code stops after each array has been processed and visually show in Immediate Window (being in VBE, Ctrl + G). Please, press F5 after each such stop. The content of each array will be dropped in A:A, one on top of the other:

Sub ExtractUniqueRndNumbersFromRanges()
   Dim sh As Worksheet, lastRow As Long, arrInit, rndNo As Long
   Dim TypeAArray(1 To 15, 1 To 1) As Variant, TypeBArray(1 To 15, 1 To 1)
   Dim TypeCArray(1 To 10, 1 To 1) As Variant, TypeDArray(1 To 10, 1 To 1) As Variant
   Dim jagArr, colsArr, filt As String, ii As Long, i As Long, lastERA As Long
   
   jagArr = Array(TypeAArray, TypeBArray, TypeCArray, TypeDArray) 'create a jagged array (an array of arrays)
   colsArr = Array("C", "E", "G", "J")                                             'create an array of columns used to extract random elements
   
   Set sh = Sheets("Sheet2") 'it may be any sheet
   sh.Range("A:A").ClearContents 'in order to repeat the code if some modifications needed
   For ii = 0 To UBound(jagArr)  'iterate between the arrays of the jagged array
        lastRow = sh.cells(sh.rows.count, colsArr(ii)).End(xlUp).Row  'last row
        arrInit = Application.Transpose(sh.Range(colsArr(ii) & "2:" & colsArr(ii) & lastRow).value) 'create a 2D array from the range
        For i = 1 To UBound(jagArr(ii))
                Randomize
                rndNo = Int((UBound(arrInit) - LBound(arrInit) + 1) * Rnd + LBound(arrInit))
                jagArr(ii)(i, 1) = arrInit(rndNo) 'fill the A array with the random array elemengt
                filt = arrInit(rndNo) & "$$$": arrInit(rndNo) = filt 'make the array element unique, to be removed
                arrInit = filter(arrInit, filt, False) 'eliminate the already extracted number
        Next i
        
        Debug.Print Join(Application.Transpose(jagArr(ii)), "|"): Stop  'visually check the filled array content in Immediate Window
        lastERA = sh.Range("A" & sh.rows.count).End(xlUp).Row + 1 'last empty row in A:A
        sh.Range("A" & lastERA).Resize(UBound(jagArr(ii)), 1).value = jagArr(ii)
    Next ii
End Sub

Please, test it and send some feedback.

If something not clear, do not hesitate to ask for clarifications.

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution Source
Solution 1 FaneDuru