Prompt for date (MM/DD/YY) to fill down a column, does not let you type a date that does not exist (ie. 9/31/2016)

[zach9208]

I am looking to update this existing code to prompt for a date to fill down column A. I want it to only except a valid date in mm/dd/yy format. Below is code that works at filling down, but accepts dates that are invalid (ie. 10/35/16). Thanks in advance for the help!

Sub MySub()
     
    Dim strAnswer As String
    Dim rngToFill As Range
    Dim lastrow As Long
    
    lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Columns("A:A").Insert Shift:=xlToRight, _
    CopyOrigin:=xlFormatFromLeft
    [A1].Formula = "asof_dt"
    
    Set rngToFill = Range("A2", Range("A2:A" & lastrow)).Offset(, 0)
    strAnswer = InputBox("Please enter an asof_dt for this file in the following format: MM/DD/YY")
    If Len(strAnswer) = 0 Then Exit Sub
     
    rngToFill = strAnswer
    Columns.AutoFit
End Sub

 

[Norie]

Try using IsDate to check for a valid date.

Sub MySub()
     
    Dim strAnswer As String
    Dim rngToFill As Range
    Dim lastrow As Long
    
    lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Columns("A:A").Insert Shift:=xlToRight, _
    CopyOrigin:=xlFormatFromLeft
    [A1].Formula = "asof_dt"
    
    Set rngToFill = Range("A2", Range("A2:A" & lastrow)).Offset(, 0)
    strAnswer = InputBox("Please enter an asof_dt for this file in the following format: MM/DD/YY")
    If Len(strAnswer) = 0 Then Exit Sub

    If Not IsDate(strAnswer) Then
        MsgBox "Please enter a valid date"
    End If
     
    rngToFill = CDate(strAnswer)

    Columns.AutoFit
End Sub

 

[zach9208]

Try using IsDate to check for a valid date.

Sub MySub()
     
    Dim strAnswer As String
    Dim rngToFill As Range
    Dim lastrow As Long
    
    lastrow = Range("B" & Rows.Count).End(xlUp).Row
    Columns("A:A").Insert Shift:=xlToRight, _
    CopyOrigin:=xlFormatFromLeft
    [A1].Formula = "asof_dt"
    
    Set rngToFill = Range("A2", Range("A2:A" & lastrow)).Offset(, 0)
    strAnswer = InputBox("Please enter an asof_dt for this file in the following format: MM/DD/YY")
    If Len(strAnswer) = 0 Then Exit Sub

    If Not IsDate(strAnswer) Then
        MsgBox "Please enter a valid date"
    End If
     
    rngToFill = CDate(strAnswer)

    Columns.AutoFit
End Sub

This kindof worked. It populated a "Please enter a valid date" popup box. But as soon as I clicked OK It threw a run time error '13' Type Mismatch.

I would like it to take me right back to the date box to enter a new date. I should add... I have more that the macro does after a valid date is entered. See code below

Sub CreateUserInitiatedLoadCSV()
Dim wbNew As Workbook, wbSrc As Workbook, Error As Range
Dim SaveToDirectory$, CurrentWorkbook$, KeepRunning As VbMsgBoxResult
Dim CurrentFormat&, nmary, sh1 As Worksheet, sh2 As Worksheet, i&, rng As Range

    Set wbSrc = ThisWorkbook
    Set sh1 = wbSrc.ActiveSheet
    Set Error = sh1.Range("A4:A" & sh1.Cells(Rows.Count, 1).End(xlUp).Row).Find("Error", LookIn:=xlValues, LookAt:=xlWhole)
    If Not Error Is Nothing Then
        KeepRunning = MsgBox("One or more errors were detected relating to a missing ODS ID. See column A for details. Would you like to proceed with creating the CSV file?", _
            Buttons:=vbExclamation + vbYesNo + vbDefaultButton2, Title:="ODS ID/Country ID Error(s) Found")
        If KeepRunning = vbNo Then Exit Sub
    End If

    nmary = Array("ODS ID#", "Counterparty", "Moodys", "S&P", "Fitch", "Country of Domicile", "Ult. Parent Country of Domicile")
    Set wbNew = Workbooks.Add

    Set sh2 = wbNew.Sheets(1)
    For i = LBound(nmary) To UBound(nmary)
        Set rng = sh1.Rows(4).Find(nmary(i), , xlValues).EntireColumn
        rng.Copy sh2.Cells(1, i + 1)
    Next
     
    sh2.Activate
    sh2.Rows("1:3").Delete Shift:=xlUp
    Call RemoveEmptyRows
    Call MySub
    
   ' Store current details for the workbook
    CurrentWorkbook = ThisWorkbook.FullName
    CurrentFormat = ThisWorkbook.FileFormat
    
    SaveToDirectory = "C:\Users\c12345\Desktop\"
    wbNew.SaveAs Filename:=SaveToDirectory & "Counterparty_Rating" & ".csv", FileFormat:=xlCSV
    wbNew.Close savechanges:=False

    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
    Application.DisplayAlerts = True
End Sub

 

[Norie]

Where do you get the error?

 

[zach9208]

So it gets to the code line Call MySub and I enter an invalid date, I click OK and it errors out right there.

 

[zach9208]

I clicked debug and it seems to be tripping on rngToFill = CDate(strAnswer)

 

[Norie]

On which line of code does the error occur?

PS I forgot something, to exit the sub when an invalid date is entered.

  If Not IsDate(strAnswer) Then
     MsgBox "Please enter a valid date"
     Exit Sub
 End If

 

[zach9208]

I clicked debug and it seems to be tripping on rngToFill = CDate(strAnswer)