VBA for Generating Cycle Counts

[bneighbors9]

I am looking for a VBA assigned to a button that will generate a cycle count for inventory control purposes. Each time I press the button, a new list will populate and not repeat any part numbers from a previous time of pressing the button. The list of part numbers with description/ location are on sheet 1 , Column B through D. The count sheet that I need this information to go to is on sheet2.

The button needs to do the following
Put todays date in the top of the sheet2
Randomly pull 15 part numbers from sheet 1 and paste that onto the count sheet (Sheet2 in A4 through A18). It needs to not select any part number that has a date in the E column.
Once a part number has been selected, put todays date in column E on sheet 1 to show the date it was selected and to stop it from being selected again.
Be able to click the button over and over again to create a new list until all part numbers have been selected 1 time.

 

[kvsrinivasamurthy]

Try.

Sub SelectPartNumbers()
Dim T&, Lr&, K&
Dim A, B, Dt
Lr = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("B2:B" & Lr)
Dt = Sheets("Sheet1").Range("E2:E" & Lr)
ReDim B(1 To UBound(A, 1), 1 To 1)
If WorksheetFunction.CountIf(Sheets("Sheet1").Range("E2:E" & Lr), "") >= 15 Then

With CreateObject("Scripting.dictionary")
For T = 1 To 15
Line1:
K = WorksheetFunction.RandBetween(1, UBound(A, 1))
If Not .exists(A(K, 1)) And Dt(K, 1) = "" Then
.Item(K) = A(K, 1): Dt(K, 1) = Date
Else
GoTo Line1
End If
Next T
Sheets("Sheet1").Range("E2:E" & Lr) = Dt
Sheets("Sheet1").Range("E2:E" & Lr).NumberFormat = "dd-mm-yyyy"
Sheets("Sheet2").Range("A4:A18") = Application.Transpose(.items)
End With

Else
MsgBox "Sufficient Part numbers are not available", vbOKOnly, "Free Part Numbers"
End If
End Sub

 

[bneighbors9]

That is amazing! The only problem is when you cycle through to the end and there is less than 15 left. It gives the error that sufficient part numbers are not available and will not pick the last few remaining numbers

 

[kvsrinivasamurthy]

When Free numbers are less than 15 what do you want

 

[bneighbors9]

It just needs to pick all the remaining numbers that are left when its less than 15

 

[bneighbors9]

Could it also copy/paste the description column and the storage bin column to go with that part number?

 

[kvsrinivasamurthy]

Deleted.

 

[bneighbors9]

That last code fixed the previous problem and selected the 13 part numbers remaining on the last round.

 

[kvsrinivasamurthy]

Try.

Sub SelectPartNumbers()
Dim T&, Lr&, cnt&, K&
Dim A, B, Dt
Lr = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("B2:D" & Lr)
Dt = Sheets("Sheet1").Range("E2:E" & Lr)
ReDim B(1 To UBound(A, 1), 1 To 1)
cnt = WorksheetFunction.Min(WorksheetFunction.CountIf(Sheets("Sheet1").Range("E2:E" & Lr), ""), 15)
If cnt > 0 Then

With CreateObject("Scripting.dictionary")
For T = 1 To cnt
Line1:
K = WorksheetFunction.RandBetween(1, UBound(A, 1))
If Not .exists(A(K, 1)) And Dt(K, 1) = "" Then
.Item(K) = Array(A(K, 1), A(K, 2), A(K, 3)): Dt(K, 1) = Date
Else
GoTo Line1
End If
Next T
Sheets("Sheet1").Range("E2:E" & Lr) = Dt
Sheets("Sheet1").Range("E2:E" & Lr).NumberFormat = "dd-mm-yyyy"
Sheets("Sheet2").Range("A4").CurrentRegion.Clear
Sheets("Sheet2").Range("A4:C" & 4 + cnt - 1) = Application.Index(.items, 0, 0)
End With

End If
MsgBox cnt & " Part numbers are selected", vbOKOnly, "Free Part Numbers"
End Sub

 

[bneighbors9]

This copies over the data but it deletes everything around it. headers and grid