Home > Net >  VBA: Select random cells based on conditions
VBA: Select random cells based on conditions

Time:10-30

I have 100 different clients with only 3 types (A, B or C). I would like to select (at random) 3 clients with Type A, 2 with type B and 30 with Type C - we can add 'y' in columne C.

enter image description here

Not sure how can I start here - thanks for any hints.

CodePudding user response:

Two steps:

  1. Save each type of client into an array (3 arrays total)
  2. Randomly select x amounts of clients out of each array

CodePudding user response:

Use a dictionary to count each type and keep selecting rows at random till all counts are zero.

Option Explicit

Sub pick()

    Const LIMIT = 1000000 ' limit iterations to solve

    Dim wb As Workbook, ws As Worksheet
    Dim lastrow As Long
    Dim dict As Object, key, bLoop As Boolean
    Dim n As Long, x As Long, sType As String

    Set dict = CreateObject("Scripting.Dictionary")
    dict.Add "A", 3
    dict.Add "B", 2
    dict.Add "C", 30

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1")
    bLoop = True
    With ws
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("C2:C" & lastrow).Cells.Clear
        Do While bLoop

            ' select random row
            x = lastrow * Rnd()   1
            sType = Trim(.Cells(x, "B"))

            ' check if needed
            If Len(.Cells(x, "C")) = 0 And dict(sType) > 0 Then
                .Cells(x, "C") = "Y"
                dict(sType) = dict(sType) - 1
                
                ' check if finished
                bLoop = False
                For Each key In dict
                    If dict(key) > 0 Then bLoop = True
                Next
            End If

            ' avoid infinite loop
            n = n   1
            If n > LIMIT Then
               For Each key In dict.keys
                   Debug.Print key, dict(key)
               Next
               MsgBox "Too many iterations to solve", vbCritical, "limit=" & LIMIT
               Exit Sub
            End If
         Loop
    End With
    MsgBox "Done in " & n & " iterations", vbInformation
End Sub
  • Related