Pick value from array at random

Luke777

Board Regular
Joined
Aug 10, 2020
Messages
243
Office Version
  1. 365
Platform
  1. Windows
Hi all,

With a lot of help from the forum, I've got myself an array containing cell addresses.

My next step in handling this data would be to pick from this list of addresses at random. I need to be able to control how many are picked (only likely to be 1 to 2 addresses) and for those picks to be unique in the case of 2 picks.

I'm not actually sure if this is possible or not - though I assume there must be a way of fudging it even if VBA isn't designed to do anything at random.

I'm imagining some sort of randbetween the ubound and lowbound of myArray - but I'm not sure on much beyond that.

Thanks all!

Edit: Should probably explain what I'm trying to do with the random cell address/addresses once they've been picked. They'll be given a .value from another variable - if its two picks, they're both the same .value:)
 
Last edited:
Update:

I think what I've smashed together here works as intended

VBA Code:
    With ws1
        For Each cell In Range(Cells(searchRow, 3), Cells(searchRow, lastCol))
            If Application.CountIf(cell.Resize(tSlots, 1), "Bob") = tSlots Then
                  s = s & "," & cell.Address                            'add to a string with "," as separator
            Else
                Cells(searchRow, lastCol + 1).Value = activityName
            End If
        Next cell
       
        If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")
       
        Dim X As Long, N As Long, Indx As Long, HowManyRandomNums As Long
        Dim ValueToAssign As Variant, Tmp As Variant, Arr As Variant
       
        HowManyRandomNums = 2
        ValueToAssign = "Some value"
        Arr = sp
       
        If HowManyRandomNums <= UBound(Arr) - LBound(Arr) + 1 Then
          For X = UBound(Arr) To LBound(Arr) Step -1
            N = N + 1
            Indx = Application.RandBetween(LBound(Arr), X)
            Range(Arr(Indx)).Value = ValueToAssign
            Arr(Indx) = Arr(X)
            If N = HowManyRandomNums Then Exit For
          Next
        Else
          MsgBox "Too many random addresses requested!", vbCritical
        End If
    End With

Thanks for the contributions everyone!

Also, what is best practice for when there's multiple 'best answers' like in this thread?
As to your last question, I think @BSALV has put the greatest effort into helping you, and deserves any solution credit. As an aside, here's another method from me that uses the Chip Pearson shuffle method seen here. (I did this purely as a coding exercise.)

VBA Code:
Sub JumbleArray()
    Dim arrIn, arrOut, Temp, i As Long, n As Long, str As String
    
    str = "Something"                                       '<< value you want to enter
    Const picks = 2                                         '<< number of picks
    arrIn = Array("$C$5", "$D$5", "$E$5", "$F$5", "$G$5")   '<< array of cells to jumble
    
    If picks > UBound(arrIn) - 1 Then
        MsgBox "Reduce number of picks"
    End If
    
    For n = LBound(arrIn) To UBound(arrIn)
        i = CLng(((UBound(arrIn) - n) * Rnd) + n)
        If n <> i Then
            Temp = arrIn(n)
            arrIn(n) = arrIn(i)
            arrIn(i) = Temp
        End If
    Next n
  
    ReDim arrOut(1 To UBound(arrIn), 1 To 1)
    For i = LBound(arrOut) To UBound(arrOut)
        arrOut(i, 1) = arrIn(i)
    Next i
    
    For i = 1 To picks
        Range(arrOut(i, 1)).Value = str
    Next i
End Sub
 
Upvote 0

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
as i remember it, i saw this earlier in this question, Rick Rothstein (same basic idea).
 
Upvote 0
as i remember it, i saw this earlier in this question, Rick Rothstein (same basic
I'm having a little trouble getting the entire code to run in a loop.

VBA Code:
Sub test14()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim searchRow As Byte, lastCol As Byte
    Dim sTime As Double, tSlots As Double
    Dim rng As Range, cell As Range
    Dim X As Long, N As Long, Indx As Long
    Dim Tmp As Variant, Arr As Variant
    Dim acName As String, acHosts As Byte
 
    Set ws1 = Worksheets(1)
    Set ws2 = Worksheets(5)
 
    'Below variables don't need to be altered once proceedure begins
    lastCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    myDates = ws1.Range("A1:A148").Value2

    For Each rng In ws2.Range("A1:A59") 'NEW looping part
        'Below variables need to advance for each promotion
        sTime = CDate(rng.Value2) + CDate(rng.Offset(0, 4).Value2)
        tSlots = (TimeValue(rng.Offset(0, 5).Value) - TimeValue(rng.Offset(0, 4).Value)) * 96
        acName = rng.Offset(0, 3).Value
        acNum = 1 'change to rng.offset(0,).Value outside of testing
        searchRow = Application.Match(sTime, myDates, 1)
     
        With ws1
            For Each cell In Range(Cells(searchRow, 3), Cells(searchRow, lastCol))
                If Application.CountIf(cell.Resize(tSlots, 1), "Bananas") = tSlots Then s = s & "," & cell.Address
            Next cell
         
            If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")
         
            Arr = sp
         
            If IsEmpty(Arr) Then
                GoTo Skip
            ElseIf acHosts <= UBound(Arr) - LBound(Arr) + 1 Then
              For X = UBound(Arr) To LBound(Arr) Step -1
                N = N + 1
                Indx = Application.RandBetween(LBound(Arr), X)
                Range(Arr(Indx)).Resize(tSlots, 1).Value = acName
                Arr(Indx) = Arr(X)
                If N = acNum Then Exit For
              Next
            Else
Skip:
              MsgBox "No availability for " & acName, vbCritical
              Cells(searchRow, lastCol + 1).Resize(tSlots, 1).Value = acName
            End If
        End With
    Next 'End of NEW loop
 
End Sub

I've marked the beginning and end of the NEW loop just to make it completely obvious what code I'm trying to get to run. The variables that are at the beginning of the loop seem to be working fine when I step through the code, they update as they should. However, I've noticed through using the Locals window, that the arrays that store the tested cell.addresses don't reset. So i tried putting erase right at the end (before Next) but then the section that puts codes into the arrays stopped working so I get an error later down the line when there's nothing to pick from. I've checked my sheet - there definately should be cells that it can add, so as far as I can tell, that isn' the issue.

Just for clarity, it works perfectly once round, but then its getting confused by variables hanging over from the last loop (I think) which it doesn't like to have cleared either lol.
 
Last edited:
Upvote 0
I'm having a little trouble getting the entire code to run in a loop.

VBA Code:
Sub test14()

    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim searchRow As Byte, lastCol As Byte
    Dim sTime As Double, tSlots As Double
    Dim rng As Range, cell As Range
    Dim X As Long, N As Long, Indx As Long
    Dim Tmp As Variant, Arr As Variant
    Dim acName As String, acHosts As Byte
 
    Set ws1 = Worksheets(1)
    Set ws2 = Worksheets(5)
 
    'Below variables don't need to be altered once proceedure begins
    lastCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    myDates = ws1.Range("A1:A148").Value2

    For Each rng In ws2.Range("A1:A59") 'NEW looping part
        'Below variables need to advance for each promotion
        sTime = CDate(rng.Value2) + CDate(rng.Offset(0, 4).Value2)
        tSlots = (TimeValue(rng.Offset(0, 5).Value) - TimeValue(rng.Offset(0, 4).Value)) * 96
        acName = rng.Offset(0, 3).Value
        acNum = 1 'change to rng.offset(0,).Value outside of testing
        searchRow = Application.Match(sTime, myDates, 1)
    
        With ws1
            For Each cell In Range(Cells(searchRow, 3), Cells(searchRow, lastCol))
                If Application.CountIf(cell.Resize(tSlots, 1), "Bananas") = tSlots Then s = s & "," & cell.Address
            Next cell
        
            If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")
        
            Arr = sp
        
            If IsEmpty(Arr) Then
                GoTo Skip
            ElseIf acHosts <= UBound(Arr) - LBound(Arr) + 1 Then
              For X = UBound(Arr) To LBound(Arr) Step -1
                N = N + 1
                Indx = Application.RandBetween(LBound(Arr), X)
                Range(Arr(Indx)).Resize(tSlots, 1).Value = acName
                Arr(Indx) = Arr(X)
                If N = acNum Then Exit For
              Next
            Else
Skip:
              MsgBox "No availability for " & acName, vbCritical
              Cells(searchRow, lastCol + 1).Resize(tSlots, 1).Value = acName
            End If
        End With
    Next 'End of NEW loop
 
End Sub

I've marked the beginning and end of the NEW loop just to make it completely obvious what code I'm trying to get to run. The variables that are at the beginning of the loop seem to be working fine when I step through the code, they update as they should. However, I've noticed through using the Locals window, that the arrays that store the tested cell.addresses don't reset. So i tried putting erase right at the end (before Next) but then the section that puts codes into the arrays stopped working so I get an error later down the line when there's nothing to pick from. I've checked my sheet - there definately should be cells that it can add, so as far as I can tell, that isn' the issue.

Just for clarity, it works perfectly once round, but then its getting confused by variables hanging over from the last loop (I think) which it doesn't like to have cleared either lol.
Edit: It's something to do with my test
VBA Code:
If Application.CountIf(cell.Resize(tSlots, 1), "Bananas") = tSlots Then s = s & "," & cell.Address
.

I've just tried it from a different starting position (A10 instead of A1 on ws2) and as far as I can tell it is doing nothing :)
 
Upvote 0
Update: might be a while on this one - after further testing, its not the loop that's breaking what I'm trying to do.

Below is what I've been running my latest test on - I haven't worked out whats going on yet but it works when the ws2.ranges are looking in row 2, but not in row 3

VBA Code:
    'Below variables don't need to be altered once proceedure begins
    lastCol = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
    myDates = ws1.Range("A1:A148").Value2
    
    'Below variables need to advance for each promotion
    sTime = CDate(ws2.Range("A3").Value2) + CDate(ws2.Range("E3").Value2)
    tSlots = (TimeValue(ws2.Range("F3").Value) - TimeValue(ws2.Range("E3").Value)) * 96
    acName = ws2.Range("D3").Value
    acNum = 2 'change to ws2.Range("").Value
    searchRow = Application.Match(sTime, myDates, 1)
    
    With ws1
        For Each cell In Range(Cells(searchRow, 3), Cells(searchRow, lastCol))
            If Application.CountIf(cell.Resize(tSlots, 1), "Busiest Unhosted") = tSlots Then s = s & "," & cell.Address
        Next cell
        
        If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")
        
        Arr = sp
        
        If IsEmpty(Arr) Then
            GoTo Skip
        ElseIf acNum <= UBound(Arr) - LBound(Arr) + 1 Then
          For X = UBound(Arr) To LBound(Arr) Step -1
            N = N + 1
            Indx = Application.RandBetween(LBound(Arr), X)
            Range(Arr(Indx)).Resize(tSlots, 1).Value = acName
            Arr(Indx) = Arr(X)
            If N = acNum Then Exit For
          Next
        Else
Skip:
          MsgBox "No availability for " & acName, vbCritical 'convert to end of build error log?
          Cells(searchRow, lastCol + 1).Resize(tSlots, 1).Value = acName 'requires handler if range not blank to avoid overwrites.
        End If
    End With

End Sub
 
Upvote 0

Forum statistics

Threads
1,212,938
Messages
6,110,784
Members
448,297
Latest member
carmadgar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top