VBA for random selection of numbers from a column with several conditions

[michavon]

Hi,
I have column A with 2198 items (every item has a unique item number) and column K with letters A or B or C
example:

column A ....... column K
250310 A
250350 B
250110 B
310140 A
120740 C
405160 C

64 items have A ; 221 items have B ; 1913 items have C

I would like to have a tool that would generate items for daily cycle counting of stock in our warehouse randomly from the list according to following conditions:
Every item from group A must be counted four times a year => 64 items per quarter => approx. 1 item daily
Every item from group B must be counted twice a year => 110 items per quarter => approx. 2 items daily
Every item from group C must be counted once a year => 478 items per quarter => approx. 8 items daily

To comply with the conditions, stock of 11 items should be counted every day. I would like to run the cycle counting equally, it means I would like to keep the distribution of the groups A / B / C into 1 item / 2 items / 8 items to be generated every day.

Thanks for your help

Michaela

 

[Peter_SSs]

Is there any way how to fix it?

Yes, that's an easy fix - just declare the arrays as String arrays rather than as Long.

I also found another error or two in the previous code. The version below I have been able to do a bit more testing on and so far haven't found any problems, so give it a try.

Sub MakeSamplesEachDay_v03()
  Dim dA As Object, dB As Object, dC As Object
  Dim ABC As Variant, SoFar As Variant, itm As Variant
  Dim Aorig(1 To 64) As String, Borig(1 To 221) As String, Corig(1 To 1913) As String, Result(1 To 11, 1 To 1) As String
  Dim i As Long, j As Long, idx As Long, lc As Long, fc As Long, k As Long
  
  Const ResultCol As String = "Z" '<- Column where each new set of data will appear
  
  Randomize
  Set dA = CreateObject("Scripting.Dictionary")
  Set dB = CreateObject("Scripting.Dictionary")
  Set dC = CreateObject("Scripting.Dictionary")
  ABC = Application.Index(Cells, Evaluate("row(2:2199)"), Array(1, 11))
    
  'Collect arrays & dictionaries for A, B & C Item Numbers
  For i = 1 To UBound(ABC)
    Select Case ABC(i, 2)
      Case "A"
        dA(ABC(i, 1)) = Empty
        Aorig(dA.Count) = ABC(i, 1)
      Case "B"
        dB(ABC(i, 1)) = Empty
        Borig(dB.Count) = ABC(i, 1)
      Case "C"
        dC(ABC(i, 1)) = Empty
        Corig(dC.Count) = ABC(i, 1)
    End Select
  Next i
  
  fc = Columns(ResultCol).Column
  lc = Rows(1).Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious).Column
  
  'If relevant dictionary is empty then re-load it
  'Remove any already used values from dictionary
  If lc >= Columns(ResultCol).Column Then
    SoFar = Range(ResultCol & 2).Resize(11, lc - fc + 1).Value
    For j = UBound(SoFar, 2) To 1 Step -1
      For i = 1 To 11
        Select Case i
          Case 1
            If dA.Count = 0 Then
              For Each itm In Aorig
                dA(itm) = Empty
              Next itm
            End If
            dA.Remove SoFar(i, j)
          Case 2 To 3
            If dB.Count = 0 Then
               For Each itm In Borig
                 dB(itm) = Empty
               Next itm
             End If
            dB.Remove SoFar(i, j)
          Case Else
            If dC.Count = 0 Then
              For Each itm In Corig
                dC(itm) = Empty
              Next itm
            End If
            dC.Remove SoFar(i, j)
        End Select
      Next i
    Next j
  End If
    
  'Choose an A from remaining dictionary items
  'If at any time a dictionary gets emptied, then re-load it
  For j = 1 To 1
    If dA.Count = 0 Then
      For Each itm In Aorig
        dA(itm) = Empty
      Next itm
    End If
    idx = Int(Rnd() * dA.Count)
    Result(j, 1) = dA.keys()(idx)
    dA.Remove Result(j, 1)
  Next j
  
  'Choose 2 x B's ....
  For j = 2 To 3
    If dB.Count = 0 Then
      For Each itm In Borig
        dB(itm) = Empty
      Next itm
      If j > 2 Then
        For k = 2 To j - 1
          dB.Remove Result(k, 1)
        Next k
      End If
    End If
    idx = Int(Rnd() * dB.Count)
    Result(j, 1) = dB.keys()(idx)
    dB.Remove Result(j, 1)
  Next j
    
  'Choose 8 x C's ....
  For j = 4 To 11
    If dC.Count = 0 Then
      For Each itm In Corig
        dC(itm) = Empty
      Next itm
      If j > 4 Then
        For k = 4 To j - 1
          dC.Remove Result(k, 1)
        Next k
      End If
    End If
    idx = Int(Rnd() * dC.Count)
    Result(j, 1) = dC.keys()(idx)
    dC.Remove Result(j, 1)
  Next j
  
  'Put results on worksheet
  Application.ScreenUpdating = False
  Columns(fc).Insert
  With Cells(1, fc)
   .Value = Date
   .Offset(1).Resize(11).Value = Result
  End With
  Application.ScreenUpdating = True
End Sub

 

[michavon]

Hi Peter,
It works, I got my 11 items for cycle counting.
Thank you very much. This is great.
Michaela

 

[Rick Rothstein]

I would like to have a tool that would generate items for daily cycle counting of stock in our warehouse randomly from the list according to following conditions:
Every item from group A must be counted four times a year => 64 items per quarter => approx. 1 item daily
Every item from group B must be counted twice a year => 110 items per quarter => approx. 2 items daily
Every item from group C must be counted once a year => 478 items per quarter => approx. 8 items daily

I haven't looked at the Group B or C counts yet, but I suspect the same question will apply. So, concentrating on Group A, what should happen on the 65th day of a quarter having 65 workdays (excluding holidays) such as the current quarter has? If you assume holidays are not worked and there are enough holidays to make the number or workdays less than 64, what should happen with the item that did not get counted that quarter? Should it be forced to be counted in the next quarter? If you don't force it, should precautions be taken to make sure it is not "not counted" in the next quarter? Remember, you are randomly selecting items so theoretically, a specific item could always be the last one in the quarter and, hence, continually be not counted.

 

[Peter_SSs]

Hi Peter,
It works, I got my 11 items for cycle counting.
Thank you very much. This is great.
Michaela

You are very welcome. Post back if it needs any tweaks.