Userform with Relative Dates

[mdo8105]

I have a userform that ask for Name, date, and other information. All of this information is outputed to another Sheet. I am wanting the user to be able to use relative dates like T for Today and have the output to convert the T to a date after I run the macro. My goal is start the code like VBdate(sDate As String) As String; however I cannot figure out how to add that to the code without throwing an error. This is my current code

Private Sub CommandButton2_Click()
Dim VBDate(sDate As String) As String
Dim sStartDate As String
Dim iRange As Integer
Dim iOperator As Integer
Dim iPos As Integer
Dim sTemp As String
Dim sInterval As String
Dim sOutDate As String
 'if start date is empty, then force them to enter a start date.
    If (TextBox3.Value = "") Then
        Call MsgBox("Please enter a start date", vbInformation, "No Start Date")
        Exit Sub
    Else
        'if start date field is not empty, set the start date variable
        sStartDate = TextBox3.Value
        If IsNumeric(Mid(sStartDate, 1, 1)) Then 'If the date starts with a number, put it in mmddyyy format, otherwise it's in relative format
            sStartDate = Format(sStartDate, "YYYY-MM-DD") 'Removing punctuation so that overall code is smaller
        Else
            sStartDate = Format(VBDate(sStartDate), "YYYY-MM-DD")
        End If
    End If
    
If IsDate(sDate) Then
        sOutDate = sDate
    Else 'the string is in relative format
        'if "+" exists in the string, then we are adding to the date
        If InStr(sDate, "+") > 0 Then
            iOperator = 1
        Else
            iOperator = -1
        End If
        
        sTemp = Replace(sDate, "+", "-") 'convert + to - for easier string manipulation
        iPos = InStr(sTemp, "-") 'find the position of the operator in the string
        
        'check that the range is a valid number
        If IsNumeric(Mid(sTemp, iPos + 1)) Then
            iRange = CInt(Mid(sTemp, iPos + 1))
        Else
            iRange = 0
        End If
        
        'Get the interval desired. ex. "T", "W", "YB", "YE", etc.
        If iPos > 0 Then
            sInterval = Trim(Left(sTemp, iPos))
        Else
            sInterval = sTemp
        End If
        
        If UCase(Left(sInterval, 1)) = "T" Or UCase(sInterval) = "TODAY" Then        'Dates relative to today
            sOutDate = DateAdd("d", (iOperator * iRange), Now())
        ElseIf UCase(sInterval) = "WEEK" Then                                        'Dates relative to this week
            sOutDate = DateAdd("ww", (iOperator * iRange), Now())
        ElseIf UCase(Left(sInterval, 2)) = "WB" Then                                 'Dates relative to this week
            sOutDate = DateAdd("d", 1 - Weekday(Now()), DateAdd("ww", (iOperator * iRange), Now()))
        ElseIf UCase(Left(sInterval, 2)) = "WE" Then                                 'Dates relative to this week
            sOutDate = DateAdd("d", 7 - Weekday(Now()), DateAdd("ww", (iOperator * iRange), Now()))
        ElseIf UCase(Left(sInterval, 1)) = "W" Then                                  'Dates relative to this week
            sOutDate = DateAdd("ww", (iOperator * iRange), Now())
        ElseIf UCase(Left(sInterval, 2)) = "MB" Then                                 'Dates relative to this month
            sOutDate = DateAdd("m", (iOperator * iRange), _
                       DateSerial(DatePart("yyyy", Now()), DatePart("m", Now()), 1)) 'assembles a date using the current year, month, and day 1
        ElseIf UCase(Left(sInterval, 2)) = "ME" Then                                 'Dates relative to this month
            sOutDate = DateSerial(Year(Now()), Month(Now()) + (iOperator * iRange) + 1, 1 - 1)
        ElseIf UCase(Left(sInterval, 1)) = "M" Or UCase(sInterval) = "MONTH" Then    'Dates relative to this month
            sOutDate = DateAdd("m", (iOperator * iRange), Now())
        ElseIf UCase(Left(sInterval, 2)) = "YB" Then                                 'Dates relative to this year
            sOutDate = DateAdd("yyyy", (iOperator * iRange), DateSerial(DatePart("yyyy", Now()), 1, 1))
        ElseIf UCase(Left(sInterval, 2)) = "YE" Then                                 'Dates relative to this year
            sOutDate = DateAdd("yyyy", (iOperator * iRange), DateSerial(DatePart("yyyy", Now()), 12, 31))
        ElseIf UCase(Left(sInterval, 1)) = "Y" Or UCase(sInterval) = "YEAR" Then     'Dates relative to this year
            sOutDate = DateAdd("yyyy", (iOperator * iRange), Now())
        ElseIf UCase(Left(sInterval, 1)) = "Q" Or UCase(sInterval) = "QUARTER" Then  'Dates relative to this quarter
            sOutDate = DateAdd("q", (iOperator * iRange), Now())
        Else                                                                         'Error trap, default to t-1
            sOutDate = DateAdd("d", -1, Now())
        End If
    End If
    
    VBDate = sOutDate
    
dcc = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 1).Value = TextBox1.Text
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 2).Value = VBDate


If OptionButton1.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "Kindergarten"
End If


If OptionButton2.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "1st"
End If


If OptionButton3.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "2nd"
End If


If OptionButton4.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "3rd"
End If


If OptionButton5.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "4th"
End If


If OptionButton6.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "5th"
End If


If OptionButton7.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 3).Value = "6th"
End If


If CheckBox1.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 4).Value = 5
End If


If CheckBox2.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 5).Value = 5
End If


If CheckBox3.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 6).Value = 10
End If


If CheckBox4.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 7).Value = 20
End If


If ComboBox1.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 8).Value = ComboBox1.Value * 20
End If


If ComboBox2.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 9).Value = ComboBox2.Value * 50
End If


If ComboBox3.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 10).Value = ComboBox3.Value * 50
End If


If ComboBox4.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 11).Value = ComboBox4.Value * 20
End If


ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 12).Formula = "=SUM(D" & dcc + 1 & ":K" & dcc + 1 & ")"


If ComboBox1.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 13).Value = ComboBox1.Value
End If


If ComboBox2.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 14).Value = ComboBox2.Value
End If


If ComboBox3.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 15).Value = ComboBox3.Value
End If


If ComboBox4.Value = True Then
ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 16).Value = ComboBox4.Value
End If




ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 17).Value = TextBox4.Text






ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 18).Value = TextBox5.Text






ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 19).Value = TextBox6.Text






ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 20).Value = TextBox7.Text






ThisWorkbook.Worksheets("Sheet2").Cells(dcc + 1, 21).Value = TextBox2.Text




'clear the data


Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
Me.TextBox4.Value = ""
Me.TextBox5.Value = ""
Me.TextBox6.Value = ""
Me.TextBox7.Value = ""
Me.OptionButton1 = False
Me.OptionButton2 = False
Me.OptionButton3 = False
Me.OptionButton4 = False
Me.OptionButton5 = False
Me.OptionButton6 = False
Me.OptionButton7 = False
Me.CheckBox1 = False
Me.CheckBox2 = False
Me.CheckBox3 = False
Me.CheckBox4 = False
Me.ComboBox1.Value = ""
Me.ComboBox2.Value = ""
Me.ComboBox3.Value = ""
Me.ComboBox4.Value = ""


Columns.AutoFit












End Sub

 

[dmt32]

Hi,
Don't have time to look at all your code but if you are wanting to enter a shortcut value in textbox & have that converted to a date then maybe following will do what you want

Private Sub CommandButton1_Click()
Dim m As Variant, sStartDate As Variant


sStartDate = Me.TextBox3.Value


m = Application.Match(sStartDate, Array("T"), False)
If Not IsError(m) Then sStartDate = Choose(m, Date): Me.TextBox3.Value = sStartDate


'if start date is empty, then force them to enter a start date.
    If Not IsDate(sStartDate) Then
        Call MsgBox("Please enter a valid start date", vbInformation, "No Start Date")
        Me.TextBox3.SetFocus
        Exit Sub
    Else
        'if start date field is date, set the start date variable
        sStartDate = Format(DateValue(sStartDate), "YYYY-MM-DD")
    End If
    'rest of your code

in this example if you enter "T" in textbox & press button, it should change entry to todays date.
You can add other shortcuts as required to the Array & Choose function shown in RED as required.

Dave

 

[mikerickson]

You might consider using a double-click rather than a T.

 

[mdo8105]

You are awesome! Thank you...

 

[mdo8105]

dmt32,

Using your recommended code:

sStartDate = Me.TextBox3.Valuem = Application.Match(sStartDate, Array("T", "t"), False)
If Not IsError(m) Then sStartDate = Choose(m, Date): Me.TextBox3.Value = sStartDate




'if start date is empty, then force them to enter a start date.
    If Not IsDate(sStartDate) Then
        Call MsgBox("Please enter a valid start date", vbInformation, "No Start Date")
        Me.TextBox3.SetFocus
        Exit Sub
    Else
        'if start date field is date, set the start date variable
        sStartDate = Format(DateValue(sStartDate), "YYYY-MM-DD")
    End If

Is there a way I can add a "+" or "-" plus a number infront of the t and have Excel recogize that I am wanting to add from today or take away from today?

 

[dmt32]

Hi,
try

Private Sub CommandButton1_Click()
Dim m As Variant, sStartDate As Variant


sStartDate = Me.TextBox3.Value
m = Application.Match(sStartDate, Array("T", "-T", "+T"), False)
If Not IsError(m) Then sStartDate = Choose(m, Date, Date - 1, Date + 1): Me.TextBox3.Value = sStartDate


'if start date is empty, then force them to enter a start date.
    If Not IsDate(sStartDate) Then
        Call MsgBox("Please enter a valid start date", vbInformation, "No Start Date")
        Me.TextBox3.SetFocus
        Exit Sub
    Else
        'if start date field is date, set the start date variable
        sStartDate = Format(DateValue(sStartDate), "YYYY-MM-DD")
    End If
    'rest of your code
End Sub

Dave

 

[mdo8105]

Hi Dave,

Thank you so much. When I try to add more Arrays it does not accept it as a valid date. For example in the Array, I had "T+2" and "T+3". Then I had within Choose( Date - 2, Date + 2)

 

[dmt32]

Hi Dave,

Thank you so much. When I try to add more Arrays it does not accept it as a valid date. For example in the Array, I had "T+2" and "T+3". Then I had within Choose( Date - 2, Date + 2)

Choose is indexed by variable m which gets its value from a match found in the Array - it is important that your choose items are in same numeric place as array list.

e.g = T+1 is 3rd element in array & Date +1 the 3rd item in choose list.


Following should do what you want:

m = Application.Match(sStartDate, Array("T", "T-1", "T+1", "T+2", "T+3"), False)
If Not IsError(m) Then sStartDate = Choose(m, Date, Date - 1, Date + 1, Date + 2, Date + 3)

Dave