macro/vba to divide data sheet into two sheet

Here we go again More captures implemented, but when checking for date value in date column, the third cell down is the only value checked in the column. Could be issue if third cell does not have date.

Sub Twosheets_u()
Dim sws2, sws3, FileToOpen, sD As String
Dim x, y, vCol, vCl
Dim src, trg, src2, trg2, a, Ub, lro, lrr, i, j, lr, n, op, oq, rp, rq As Long
Dim ws, wso, wsr, wsa, wsb As Worksheet
Dim OpenWB As Workbook
Dim EndDate, StartDate As Date
Dim RngA, Result As Range

Application.ScreenUpdating = False

    Set ws = Sheets("studump")
 
    FileToOpen = Application.GetOpenFilename(Title:="Select File to Open where sheets will be added", _
                 FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen = "False" Then Exit Sub
    Set OpenWB = Workbooks.Open(Filename:=FileToOpen, ReadOnly:=False)

    sws2 = InputBox("Please enter the name for the first worksheet?")
        For Each wsa In OpenWB.Worksheets
            If wsa.Name = sws2 Then
                sws2 = sws2 & Int((900 - 1 + 1) * Rnd + 1)
            Else
                sws2 = sws2
            End If
        Next wsa
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws2
    Set wso = OpenWB.Sheets(sws2)
    sws3 = InputBox("Please enter the name for the 2nd worksheet?")
        For Each wsb In OpenWB.Worksheets
            If wsb.Name = sws3 Then
                sws3 = sws3 & 1
            Else
                sws3 = sws3
            End If
        Next wsb
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = sws3
    Set wsr = OpenWB.Sheets(sws3)
    On Error Resume Next
Pre1:
    x = Split(InputBox("type from_what_row_number_in_sheet1, to_what_row_number_in_sheet1. Example : 2,200 "), ",")
    src = x(0)
    trg = x(1)
    If Err.Number <> 0 Or trg <= src Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre1
    End If
    On Error Resume Next
Pre2:
    y = Split(InputBox("type from_what_row_number_in_sheet2, to_what_row_number_in_sheet2. Example : 200,500 "), ",")
    src2 = y(0)
    trg2 = y(1)
    If Err.Number <> 0 Or trg2 <= src2 Then
        MsgBox "Don't forget to use commas or use ascending values"
        On Error GoTo -1
        GoTo Pre2
    End If
    On Error Resume Next
Pre3:
    vCol = InputBox("Please enter the column letters you want transferred, seperated by commas, no spaces." & vbNewLine & "Also Enter date Column")
    vCl = Split(vCol, ",")
    'MsgBox InStr(vCol, ",")
    If Err.Number <> 0 Or InStr(vCol, ",") = 0 Then
        MsgBox "Don't forget to use commas"
        On Error GoTo -1
        GoTo Pre3
    End If
    Ub = UBound(vCl)
    On Error GoTo EH:
Pre4:
    sD = InputBox("Please enter which of the columns hold the dates." & vbNewLine & "Enter one letter")
    If Not IsDate(ws.Cells(3, sD)) Then 'Possible issue, this line only checks the third cell down
        MsgBox "This column needs to have a date"
        GoTo Pre4
    End If
    Set Result = ws.Columns("A")
    lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
    Set RngA = ws.Range("A1:AV" & lr)
    
    With ws
        .Activate
        For i = lr To 2 Step -1
            If Application.WorksheetFunction.IsText(Cells(i, sD)) _
            Or Cells(i, sD) = 0 Or IsNumeric(Cells(i, sD)) Then
                Cells(i, sD).EntireRow.Delete
            End If
        Next i
    End With

    For n = LBound(vCl) To UBound(vCl)
        With ws
            Set Result = Application.Union(ws.Columns(vCl(n)), Result)
        End With
    Next n

    Result.Copy
        wso.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    Result.Copy
        wsr.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    With wso
        .Activate
        For op = lr To trg Step -1
            If (Cells(op, 1)) <> "" Then Cells(op, 1).EntireRow.Delete
        Next op
        For oq = src To 2 Step -1
            If (Cells(oq, 1)) <> "" Then Cells(oq, 1).EntireRow.Delete
        Next oq
        wso.Columns.AutoFit
    End With
    
    With wsr
        .Activate
        For rp = lr To trg2 Step -1
            If (Cells(rp, 1)) <> "" Then Cells(rp, 1).EntireRow.Delete
        Next rp
        For rq = src2 To 2 Step -1
            If (Cells(rq, 1)) <> "" Then Cells(rq, 1).EntireRow.Delete
        Next rq
        wsr.Columns.AutoFit
    End With
   
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
Exit Sub
EH:
    MsgBox "This is an error  " & Err.Description
    With Application
    .CutCopyMode = False
    .ScreenUpdating = True
    End With
    On Error GoTo -1
End Sub