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:
is a system collections arraylist a reliable tool ?Sometimes it works a week/month without problem and then automatisation error and you can start explaining
VBA Code:
  Set arrList = CreateObject("System.Collections.ArrayList")
 

Attachments

  • Schermafbeelding 2022-02-01 074059.png
    Schermafbeelding 2022-02-01 074059.png
    31.7 KB · Views: 6
Upvote 0

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Okay, I'll do like the other volunteers and assume a one-dimensional array. The following code is about as efficient as possible... it will only loop as many times as the number of random addresses you specify you want. For your example two addresses, the loop only iterates two times. The code also assigns the specified common value to the randomly selected addresses directly. All you have to do is assign the three values shown.
VBA Code:
Sub AssignSameValueToRandomArrayAddresses()
  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 = Array("$C$5", "$D$5", "$E$5", "$F$5", "$G$5")
  
  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 Sub
 
Upvote 0
Show us the part of your code that puts values into the array elements.
My code is the below

VBA Code:
For Each cell In Range(Cells(searchRow, 3), Cells(searchRow, lastCol))
            If Application.CountIf(cell.Resize(tSlots, 1), "Bob") = tSlots Then
                If myArray(0) = 0 Then
                    myArray(0) = cell.Address
                Else
                    ReDim Preserve myArray(UBound(myArray) + 1)
                    myArray(UBound(myArray)) = cell.Address
                End If
            Else
                Cells(searchRow, lastCol + 1).Value = activityName
            End If
        Next cell

I'm not sure if its compatible with the suggestions given - again, my array knowledge is lacking - due to lines of code like "Arr = Array("$C$5", "$D$5", "$E$5", "$F$5", "$G$5")". I'm not sure how I'd adapt that for an array with an unknown number of cell addresses within

sorry for being awkward lol

Also didn't expect quite so many responses! Thank you everyone!
 
Upvote 0
VBA Code:
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
     End If
Else
     Cells(searchRow, lastCol + 1).Value = activityName
End If
Next cell

If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")                   'cells found = make that array, split on "," and forget the first
 
Upvote 0
VBA Code:
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
     End If
Else
     Cells(searchRow, lastCol + 1).Value = activityName
End If
Next cell

If Len(s) > 0 Then sp = Split(Mid(s, 2), ",")                   'cells found = make that array, split on "," and forget the first
Ah, so with this method I no longer need myArray - instead I have sp(0) to sp(5) with my test row, which I think I should be able to use with some of the above suggestions to then pick from at random? Edit: Not sure how to use the previous suggestions with this method having had another look.

Also, this works (After removing that first End IF before the Else) - but do I need to declare s and sp at any stage? I'm still trying to workout why some things need declaring and other things don't.

Also, thanks for your help so far!
 
Upvote 0
I'm still trying to workout why some things need declaring and other things don't.
as less as possible, you can also declare s as "dim s" and then excel makes a variant of it.
Sometimes i declare a "sAd" , this "dim sAd" and further in the macro, when i use that variable it is case-sensitive, so for me it's to eliminate errors.

Any of the methods above can be use, but my RandArray has base 1, it starts at 1 instead of 0, point of attention.
 
Upvote 0
Any of the methods above can be use, but my RandArray has base 1, it starts at 1 instead of 0, point of attention.
Ah, so using as is I'd always skip over the first result?

Edit: and is the method you're referring to this one?

VBA Code:
Sub RandomPick()
     rand = WorksheetFunction.RandArray(10)                     'suppose your array has 10 elements
     For i = 1 To UBound(rand)                                  'how many times do you want to pick ?
          r = Application.Match(Application.Small(rand, i), rand, 0)
          s = s & ", " & r
          MsgBox r                                              'random pick
     Next
     MsgBox Mid(s, 2)                                           '10 picks
End Sub
 
Upvote 0
Ah, so using as is I'd always skip over the first result?

Edit: and is the method you're referring to this one?

VBA Code:
Sub RandomPick()
     rand = WorksheetFunction.RandArray(10)                     'suppose your array has 10 elements
     For i = 1 To UBound(rand)                                  'how many times do you want to pick ?
          r = Application.Match(Application.Small(rand, i), rand, 0)
          s = s & ", " & r
          MsgBox r                                              'random pick
     Next
     MsgBox Mid(s, 2)                                           '10 picks
End Sub
Ah! so I think I could replace RandArray(10) with RandArray(sp)?
 
Upvote 0
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?
 
Upvote 0
a general macro and then 2 macros with a different way of solving
VBA Code:
Option Compare Text

Const picks = 3
Const searchrow = 5
Const lastcol = 26
Const tslots = 1
Public sp

Sub General()
     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), ",")                            'cells found = make that array, split on "," and forget the first
          bsalv1                                                '1st method
          bsalv2                                                '2nd method
     End If
End Sub

Sub bsalv1()
     rand = WorksheetFunction.RandArray(UBound(sp) + 1)         'suppose your array has 10 elements
     For i = 1 To Application.Min(picks, UBound(rand))          'how many times do you want to pick ?
          r = Application.Match(Application.Small(rand, i), rand, 0)
          s = s & ", " & sp(r - 1)
     Next
     MsgBox "BSALV1 : " & Mid(s, 2)
End Sub

Sub bsalv2()                                                    'variant of Kevin9999
     Dim arr(), arr2()
     ReDim arr(1 To UBound(sp) + 1, 1 To 2)
     For i = 1 To UBound(arr)
          arr(i, 1) = sp(i - 1): arr(i, 2) = Rnd()
     Next
     arr1 = Application.Transpose(Application.Index(Application.Sort(arr, 2), 0, 1))
     arr2 = arr1
     If picks < UBound(arr2) Then ReDim Preserve arr2(1 To picks)
     MsgBox "BSALV2 : " & Join(arr2, ",")
End Sub
 
Upvote 0

Forum statistics

Threads
1,212,927
Messages
6,110,695
Members
448,293
Latest member
jin kazuya

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