Try
Sub test2()
Dim StNum, x, i As Long
StNum = Application.InputBox("Enter Number", Type:=1)
If StNum = False Then Exit Sub
With Range("f2", Range("f" & Rows.Count).End(xlUp))
x = Filter(Evaluate("transpose(if(" & .Address & "=""Pick"",row(2:" & .Rows.Count & ")))"), False, 0)
If UBound(x) = -1 Then Exit Sub
ReDim Preserve x(UBound(x) + 1)
x(UBound(x)) = .Cells(.Count).Row + 1
.Offset(, -4).UnMerge
End With
For i = 0 To UBound(x) - 1
With Range(Cells(x(i), "b"), Cells(x(i + 1) - 1, "b"))
.Merge
.Value = StNum + i
End With
Next
End Sub
Bookmarks