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]

Welcome to the MrExcel board!

So, could we make all the lists for the whole year right now? If so, how many days per week?
Or do you just want to create the day's list day-by-day?

 

[michavon]

Hi Peter,
I would like to create a list day-by-day with requested items for cycle counting.
I thought that I'd just press the macro button every morning every day and get my 11 items. Tried to find a formula but I think specifications are too complicated.
I could put the items in order in my spreadsheet. It means A items would be K2:K65, B items K66:K286 and C items K287:K2199. If it makes the script easier...

 

[Peter_SSs]

I would like to create a list day-by-day with requested items for cycle counting.
I thought that I'd just press the macro button every morning every day and get my 11 items. Tried to find a formula but I think specifications are too complicated.
I could put the items in order in my spreadsheet. It means A items would be K2:K65, B items K66:K286 and C items K287:K2199. If it makes the script easier...

The code below could have been a bit simpler if the items were grouped together, but I had already starting thinking about the code if the data was unsorted like your original sample so I have left it that way. So the code should work whether sorted or not.

I'm not sure if you have anything to the right of column K, but I have assumed that column Z and beyond is available for the results. You will see that can easily be altered near the start of the code.
Each time you run the code, any existing results (they need to be retained to know what has already been tested) will be pushed to the right and the new results always displayed in column Z. The code also puts the current date at the top of column Z to give you a record of what was tested on any particular date. For testing, it doesn't matter that a lot of columns (all) will have the same date at the top.

I have assumed headings in row 1 with data starting in row 2.

Give it a go in a copy of your workbook.

Sub MakeSamplesEachDay()
  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 Long, Borig(1 To 221) As Long, Corig(1 To 1913) As Long, Result(1 To 11, 1 To 1) As Long
  Dim i As Long, j As Long, idx As Long, lc As Long, fc 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
    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
    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,
I tried to run the macro but got a message "Type mismatch". I am not sure if it was me who made a mistake or there is a typo in your code.
If you don't mind I would send you whole workbook to check the code with the spreadsheet.
Thanks
Michaela

 

[Peter_SSs]

Hi Peter,
I tried to run the macro but got a message "Type mismatch". I am not sure if it was me who made a mistake or there is a typo in your code.
If you don't mind I would send you whole workbook ..

I doubt a typo as it worked for me and I copy/pasted to my reply. When you get the error, report the full error message & click ‘Debug’ & also report which line is highlighted.

In relation to sending the file, that is not permissible - refer to #4 of the forum rules (link in my signature block below)

 

[michavon]

Hi Peter,
Sorry I didn't know that.
Full error message: Run-time error '13'
This one is the yellow row:
Aorig(dA.Count) = ABC(i, 1)
It's the seventeenth from the top.

And thank you, I really appreciate what you do for me.
Michaela

 

[Peter_SSs]

OK, I will look at it again when I can - might be a day or two or even a bit longer.

I have also realized that in an occasional circumstance the code could duplicate an item number on one day. More about that later too.

 

[Peter_SSs]

I tried to run the macro but got a message "Type mismatch".

This one is the yellow row:
Aorig(dA.Count) = ABC(i, 1)

Could you have any error values or text values in column A? Your original description and sample indicated numerical values.

If you are not sure .... when you get the error, click Debug again and hover your cursor over the variable i in that yellow highlighted line and look at the value in the pop-up box. Suppose the value of i is 23, then look at row 24 in the worksheet for the (first) problem row.

I have also realized that in an occasional circumstance the code could duplicate an item number on one day. More about that later too.

I think this adjusted code should stop that occurring.

Sub MakeSamplesEachDay_v02()
  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 Long, Borig(1 To 221) As Long, Corig(1 To 1913) As Long, Result(1 To 11, 1 To 1) As Long
  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
          dB.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,
when I hovered the cursor over i => i=1 and when I moved it a little bit over ABC, the message popped up: ABC(i, 1)="0940042AM43".
As for column A - some of our items are only numerical but most of them contain text values. I should have mentioned it. Sorry, didn't know it was important. So I guess this is the mistake.
Is there any way how to fix it?
Thanks
Michaela