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&, cnt&
Dim A, B, Dt, M
Lr = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("B2:D" & Lr)
Dt = Sheets("Sheet1").Range("E2:E" & Lr)
cnt = WorksheetFunction.Min(WorksheetFunction.CountIf(Sheets("Sheet1").Range("E2:E" & Lr), ""), 15)
M = Filter(Evaluate("transpose(If('Sheet1'!e2:e" & Lr & "="""",ROW('Sheet1'!b2:b" & Lr & ")-ROW($A$1),False))"), False, False)
If cnt > 0 Then
ReDim B(0 To cnt - 1, 1 To 3)
For T = 0 To cnt - 1
B(T, 1) = A(M(T), 1): B(T, 2) = A(M(T), 2): B(T, 3) = A(M(T), 3): Dt(M(T), 1) = Date
Next T
Sheets("Sheet1").Range("E2:E" & Lr) = Dt
Sheets("Sheet1").Range("E2:E" & Lr).NumberFormat = "dd-mm-yyyy"
With Sheets("Sheet2")
.Range("A4:C18").Clear
.Range("A4:C" & 4 + cnt - 1) = B
.Range("B1") = Date
End With
Else
Sheets("Sheet2").Range("A4:C18").Clear
End If

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

 

[bneighbors9]

This is working how it needs to for the data, but it is removing the format that it was in.

 

[kvsrinivasamurthy]

There is no code for changing the Format of cells.
Here is the sample of Result for 1st 15 Lines

VBA for Generating Cycle Counts.xlsm
	A	B	C	D
1		07-02-2025
2
3
4	157221225	SEAT	HJ12FSP01A
5	08036D1630	CLIP	HJ12FSP01B
6	2A54611C50KC	PLATE ASSY CLAMP	HJ12FSP01C
7	2A670K1191	BRACKET	HJ12FSP01C
8	2079707420	BRACKET	HJ12FSP02A
9	2079707430	BRACKET	HJ12FSP02A
10	207943A130	BRACKET	HJ12FSP02B
11	2069437A90	small strip	HJ12FSP02C
12	20Y9703572	BRACKET	HJ12FSP03A
13	2089707180	BRACKET ARM	HJ12FSP03B
14	2089707190	BRACKET ARM	HJ12FSP03B
15	20Y7042E51	PLATE	HJ12FSP03B
16	2067072B60	PIPE	HJ12FSP03C
17	20Y7022H50	Grease tube	HJ12FSP03C
18	2A76215610	BRACKET	HJ12FSP04A
19
Sheet2

 

[kvsrinivasamurthy]

Try this code.

Sub SelectPartNumbers()
Dim T&, Lr&, cnt&
Dim A, B, Dt, M
Lr = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("B2:D" & Lr)
Dt = Sheets("Sheet1").Range("E2:E" & Lr)
cnt = WorksheetFunction.Min(WorksheetFunction.CountIf(Sheets("Sheet1").Range("E2:E" & Lr), ""), 15)
M = Filter(Evaluate("transpose(If('Sheet1'!e2:e" & Lr & "="""",ROW('Sheet1'!b2:b" & Lr & ")-ROW($A$1),False))"), False, False)
If cnt > 0 Then
ReDim B(0 To cnt - 1, 1 To 3)
For T = 0 To cnt - 1
B(T, 1) = A(M(T), 1): B(T, 2) = A(M(T), 2): B(T, 3) = A(M(T), 3): Dt(M(T), 1) = Date
Next T
Sheets("Sheet1").Range("E2:E" & Lr) = Dt
Sheets("Sheet1").Range("E2:E" & Lr).NumberFormat = "dd-mm-yyyy"
With Sheets("Sheet2")
.Range("A4:C18").Clear
.Range("A4:C18").NumberFormat = "@"
.Range("A4:C" & 4 + cnt - 1) = B
.Range("A4:C18").EntireColumn.AutoFit
.Range("B1") = Date
End With
Else
Sheets("Sheet2").Range("A4:C18").Clear
End If

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

 

[bneighbors9]

That fixed the numbers that started with zero.

I changed .Range("A4:C18").Clear to .Range("A4:C18").ClearContents and that fixed the problem !

 

[kvsrinivasamurthy]

Ok . Thank you.

 

[bneighbors9]

Thank you ! This is perfect