split data into multiple worksheets vba code

1Sub parse_data()
2    Dim lr As Long
3    Dim ws As Worksheet
4    Dim vcol, i As Integer
5    Dim icol As Long
6    Dim myarr As Variant
7    Dim title As String
8    Dim titlerow As Integer
9
10    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
11    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
12
13    Application.ScreenUpdating = False
14    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
15    Set ws = ActiveSheet
16    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
17    title = "A1"
18    titlerow = ws.Range(title).Cells(1).Row
19    icol = ws.Columns.Count
20    ws.Cells(1, icol) = "Unique"
21    For i = 2 To lr
22        On Error Resume Next
23        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
24            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
25        End If
26    Next
27
28    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
29    ws.Columns(icol).Clear
30
31    For i = 2 To UBound(myarr)
32        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
33        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
34            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
35        Else
36            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
37        End If
38        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
39        'Sheets(myarr(i) & "").Columns.AutoFit
40    Next
41
42    ws.AutoFilterMode = False
43    ws.Activate
44    Application.ScreenUpdating = True
45End Sub