Split column in excel based on criteria in another column - vba

Question

Below is my code; where I try to split column's Code data into different sheets.
My problem is that; I need to enter a new condition to take from Column Orders; where I store numbers from 1-50000 specific range of values each time and produce the final sheets.
For Example : I want the Sheets "101" "102" "501" with data from Column "Orders" ONLY with values=> 0<=value and value=<50.
The "value" to be populated by the user=> "Please Insert Orders from"=> 0
"Please Insert Orders up to"=>50
Thnks in advance!
data
Private Sub Run_Click()
Dim LR As Long
Dim ws As Worksheet
Dim vCol, i, j As Integer
Dim icol As Long
Dim MyArr As Variant
Dim title As String
Dim titlerow As Integer
'1-store user input in 'Fullo' variable
Dim Fullo As String
Fullo = InputBox("Please insert sheet of analysis:", "Collect User Input")
'test input before continuing to validate the input
If Not (Len(Fullo) > 0) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
'2-store user input in 'CN' variable
Dim CN As Integer
CN = InputBox("Please insert column of analysis:", "Collect User Input")
'test input before continuing to validate the input
If Not (Len(CN) > 0 And IsNumeric(CN)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
'3-store user input in 'CN' variable
Dim HKFrom As Integer
HKFrom = InputBox("Please insert Orders from:", "Collect User Input")
'test input before continuing to validate the input
If Not (Len(HKFrom) > 0 And IsNumeric(HKFrom)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
'4-store user input in 'CN' variable
Dim HKUntil As Integer
HKUntil = InputBox("Please insert Orders up to:", "Collect User Input")
'test input before continuing to validate the input
If Not (Len(HKUntil) > 0 And IsNumeric(HKUntil)) Then
MsgBox "Input not valid, code aborted.", vbCritical
Exit Sub
End If
vCol = CN
Set ws = Sheets(Fullo)
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
title = "A1:H1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To LR
On Error Resume Next
If ws.Cells(i, vCol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vCol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vCol)
End If
'error handling
Next
MyArr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(MyArr)
ws.Range(title).AutoFilter Field:=vCol, Criteria1:=MyArr(i) & ""
If Not Evaluate("=ISREF('" & MyArr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(i) & ""
Else
Sheets(MyArr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & LR).EntireRow.Copy Sheets(MyArr(i) & "").Range("A1")
Sheets(MyArr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub