Userform with Relative Dates

M

mdo8105

Board Regular
Joined
Nov 13, 2015
Messages
83
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
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
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Sort by date Sort by votes
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

Rich (BB code): 
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
 
Upvote 0
dmt32,

Using your recommended code:
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?
 
Upvote 0
Hi,
try

Code: 
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
 
Upvote 0
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)
 
Upvote 0
mdo8105 said:
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)
Click to expand...

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:

Code: 
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
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
subscript out of range when I reference a valid UserForm
Replies
2
Views
95
Roland Hoelscher
R
K
  • Question Question
create fixtures but 2 vs 2
Replies
7
Views
205
kerm007
K
I
  • Question Question
Worksheet value is updated only after userform is closed
2
Replies
13
Views
515
ipbr21054
I
I
  • Question Question
Advice to remove old code for a new code
Replies
2
Views
212
ipbr21054
I
N
  • Question Question
VBA loop to duplicate sheets between one existing excel file and anew one
Replies
2
Views
138
ND1979
N

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top