Add x number of days to a date with vba in excel - date

I am tring to add x number of days to a Long date with a pop up box.
Public Function AskForDeadlinePlus4() As String
Dim strUserResponse As String
strUserResponse = InputBox("Enter Validuntil Date: Add # of Days To Survey end date")
strUserResponse = FormatDateTime(strUserResponse + I2, vbLongDate)
ActiveSheet.Cells(2, 10).Value = strUserResponse 'the 2, 10 is the cell reference for J2 - row 2, column 10.
End Function
Where Survey end date in cell I2.
When I run this I get (Googling how to do this I am tiring)
4 + I2 (where I2 = Friday, April 05, 2013) >> Wednesday, January 03, 1900
of course I need Tuesday, April 09, 2013
Thanks

Have you used the DateAdd function?
Sub DateExample()
Dim strUserResponse As String '## capture the user input'
Dim myDate As Date '## the date you want to add to'
Dim numDays As Double '## The number of days you want to add'
strUserResponse = InputBox("Enter Validuntil Date: Add # of Days To Survey end date")
numDays = InputBox("How many days to add?")
myDate = CDate(strUserResponse)
MsgBox DateAdd("d", numDays, myDate)
End Sub

I think this code is what your after using the DateAdd(<base e.g. Day = "D">, <number>, <date>) function:
Public Function AskForDeadlinePlus4() As String
Dim strUserResponse As Date, iNumber As Long, rResponse As Variant
AskForDeadlinePlus4 = "" 'set default value
iNumber = CLng([I2])
rResponse = InputBox("Enter Validuntil Date: Add " & iNumber & " Day(s) To Survey end date")
If rResponse = False Then
'no value entered
Exit Function
ElseIf Not IsDate(rResponse) Then
'no date entered
Exit Function
Else
'valid date entered
strUserResponse = DateAdd("D", iNumber, CDate(rResponse))
End If
AskForDeadlinePlus4 = FormatDateTime(strUserResponse, vbLongDate)
End Function
Just a few points though:
The input function will return the Boolean FALSE if no input is entered.
The test you used above is a function and will return a value when used
If you want to use in in another VBA code, i = AskForDeadlinePlus4 is its usage;
But you can also use it in a cell but only when necessary as with every calculation this will prompt an input and for every cell its in, =AskForDeadlinePlus4; and
Plus I've added a check to see if a date was entered as the user may not enter a valid one.
If you want to use in VBA:
Sub GetInfo()
'the 2, 10 is the cell reference for J2 - row 2, column 10.
ActiveSheet.Cells(2, 10).Value = AskForDeadlinePlus4
End Sub

Instead of using DateAdd, which requires more typing, you could also use DateValue. Following would do it.
DateValue(strUserResponse )+I2
Another solution would be using the conversion function, CDate.
CDate(strUserResponse )+I2

Related

VB6 Alternate 7 images every calendar week continuously

I am (still) programming in VB6, but I think this problem is not program language related.
I need to show one Picture out of 7 Pictures (named 1.jpg to 7.jpg) every calendar week, beginning with Calendar week 3, which shows picture nr.1
Example:
(year and calendar week together as 2022/03)
202203=1.jpg
202204=2.jpg
202205=3.jpg
202206=4.jpg
202207=5.jpg
202208=6.jpg
202209=7.jpg
202210=1.jpg
202211=2.jpg
etc.
How can I do this??
Also, Years can have 52 or 53 weeks, but this has to continue like above...
Appreciate any help, thank you in advance.
Here is some code that gives the results you desire. It should be fairly self-explanatory:
Option Explicit
Private Sub Test()
Dim dt As Date
Dim i As Integer
dt = DateSerial(2022, 1, 17) 'start at 3rd calendar week
For i = 1 To 100
Debug.Print Format(dt, "mm/dd/yyyy") & vbTab & Year(dt) & _
Format(ISOWeekNumber(dt), "00") & vbTab & GetPicture(dt)
dt = DateAdd("d", 1, dt)
Next
End Sub
Private Function GetPicture(ByVal dt As Date) As String
Dim dp As Integer
dp = ISOWeekNumber(dt) Mod 7 - 2
If dp <= 0 Then dp = dp + 7
GetPicture = dp & ".jpg"
End Function
Private Function ISOWeekNumber(ByVal dt As Date) As Integer
ISOWeekNumber = DatePart("ww", dt, vbMonday, vbFirstFourDays)
End Function
This produces the following results:

VBA to format long date with week day to short date

I am looking to take the date Friday, 08 July 2022, and convert it to 7/8/2022. I originally had a manual process to find and replace the date but if I can add it to the code it would be more efficient. The date moves to the summary tab and can be formatted there or before it moves.
Any help is appreciated, thank you!
Tea
Sub Datacleanup()
Dim c As Range, cDest As Range, lr As Long
Set cDest = Worksheets("summary").Cells(Rows.Count, "A").End(xlUp).Offset(1) 'first paste position
Set c = Worksheets("raw").Range("A1") 'start search here
lr = c.EntireColumn.Cells(Rows.Count).End(xlUp).Row 'last row of data in colA
Do While c.Row < lr
If Len(c.Value) > 0 And Application.CountA(c.EntireRow) = 1 Then
cDest.Resize(1, 3).Value = Array(c.Offset(2, 0).Value, _
c.Value, c.Offset(2, 14).Value)
Set cDest = cDest.Offset(1) ' next destination row
Set c = c.Offset(3) 'skip data block
Else
Set c = c.Offset(1) 'next row
End If
Loop
End Sub

Macro to find user input date range and delete everything outside range

Wondering if someone could help me in developing a simple user interfacing macro.
I have a set of data with the first Column (A) being dates. The date range can be an arbitrary range so could go from any start date to end date (most of the time its a 6/8 weeks). Lets say for arguments sake the date range goes from 31/12/2014 18:00 to 09/02/2015 18:00 (note date is UK format of dd/mm/yyyy). I would like the user to be asked for a start and end date range that they went - say 01/01/2015 to 31/01/2015. Once they have chosen the range the macro should delete everything BEFORE their selected date range (and shift cells up) and delete everything AFTER their selected date range. The date range is in increments of 10 minutes.
I've written some code to start off:
Public Sub DateRngInput()
Dim startDate As String
Dim endDate As String
Dim sRow As Long
Dim eRow As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
startDate = Left(Worksheets("Template").Cells(1, 1), 10)
endDate = Left(Worksheets("Template").Cells(lastRow, 1), 10)
sDate = InputBox("Choose Start date (dd/mm/yyyy)" & vbNewLine & vbNewLine & "Data range starts at " & startDate)
eDate = InputBox("Choose End date (dd/mm/yyyy)" & vbNewLine & vbNewLine & "Data range ends at " & endDate)
'On Error Resume Next
sRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(sDate, LookAt:=xlPart).Row
eRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(eDate, SearchDirection:=xlPrevious, LookAt:=xlPart).Row
MsgBox ("Your date range is from: " & vbNewLine & sDate & " at Row " & sRow & vbNewLine & "To " & vbNewLine & eDate & " at Row " & eRow)
End Sub
The macro errors out at the following line with the Run-Time error '91':
sRow = Worksheets("Template").Range("$A$1:$A" & lastRow).Find(sDate, LookAt:=xlPart).Row
Any help would be much appreciated!
Thanks.
Say we have data like:
Notice the material is not even sorted! We wish to retain only data between 1 February 2015 and 15 February 2015.
We will loop from the bottom moving up. We delete all rows outside the date limits
Sub DateKleaner()
Dim early As Date, late As Date, N As Long
Dim dt As Date
early = DateSerial(2015, 2, 1)
late = DateSerial(2015, 2, 15)
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
dt = Cells(i, 1).Value
If dt > late Or dt < early Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
We will be left with:
EDIT#1:
Here is some code which asks the User to supply the dates:
Sub DateKleaner()
Dim early As Date, late As Date, N As Long
Dim dt As Date
early = CDate(Application.InputBox(Prompt:="Please enter start date:", Type:=2))
late = CDate(Application.InputBox(Prompt:="Please enter end date:", Type:=2))
MsgBox early & vbCrLf & late
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 1 Step -1
dt = Cells(i, 1).Value
If dt > late Or dt < early Then
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub
Naturally you would probably use your own UserForm to accomplish the same thing.

macro to extract dates from a weeks date range string and add 7 days to print next date range

I am writing a macro that processes an excel with lots of data. One of the rows contains a date range like wkstartdate - wkenddate and I would like to use dateadd function to print next date range every week (like '27-01-14 - 02-02-14' in below case) but unable to do so.
'06-01-14 - 12-01-14'
'13-01-14 - 19-01-14'
'20-01-14 - 26-01-14'
I used below excerpt which fails:
Range("E" & Lastrow).Select
prwk = Split(ActiveCell.Value, "-")
'curr_wkstart = DateAdd("d", 7, prwk(1)) 'error as maybe prwk(1) isnt correct format
'curr_wkend = DateAdd("d", 7, prwk(2)) 'error
Range("E" & Lastrow + 1).Value = curr_wkstart & curr_wkend 'no result
For testing purpose I print, prwk(1) which is 20/01/14 in the above case, in a diff cell and add 7 days, which gives me 1/21/2020 instead of '27/01/14'. I also tried using Cdate function, but still error
Can you please advise??
I think what you want to use here are the Format and DateSerial functions. Here's how I came at it:
Function GetNextWeek(TheStartWeek)
a = Split(TheStartWeek, " - ")
b = Split(a(1), "-")
c = DateSerial(b(2), b(1), b(0)) + 1
d = c + 6
GetNextWeek = Format(c, "dd-mm-yy") & " - " & Format(d, "dd-mm-yy")
End Function
Sub Test()
Debug.Print GetNextWeek("13-01-14 - 19-01-14") 'Givs you "20-01-14 - 26-01-14"
End Sub
Hope this helps.

Data control from textbox and inverted day/month values

I need to check if the date entered in a textbox is valid. It has to be a single textbox, so no workaround this way.
Now, I have this code:
Private Sub cmdOK_Click()
Dim dataAnalisi As Date
If IsDate(txtDataAnalisi.Value) Then
dataAnalisi = txtDataAnalisi.Value
Dim giornoAnalisi, meseAnalisi As Integer
giornoAnalisi = Format(dataAnalisi, "dd")
meseAnalisi = Format(dataAnalisi, "mm")
If giornoAnalisi <= 31 And meseAnalisi <= 12 Then
Call arrayList(dataAnalisi)
Unload Me
Else
GoTo DateError
End If
Else
DateError:
MsgBox "Inserire una data formattata correttamente!", vbCritical, "Errore nell'inserimento!"
txtDataAnalisi.SetFocus
End If
End Sub
Sorry if it has text in Italian. The function works decently, the only problem is that if I input for instance 11/14/12 (where the date is dd/mm/yy and 14 was a mistype) it inverts the day and month values. Instead, I want the sub to tell the user to check his input again! Can you help me? Thank you!
There are variations of this question every month or so. I am convinced that Excel will treat a date that is a valid American date as an American date. I have thought this for many years but others disagree.
I use functions like the one below which check for formats I believe Excel will misinterpret and convert them to an unambiguous format.
I use the English abbreviations for months. I believe French is the only language that does not permit three character abbreviations for months so perhaps you have your own set. You will have to adapt that part of the routine to your requirement.
Hopes this helps.
Function MyDateValue(ByVal DateIn As String, ByRef DateOut As Date) As Boolean
' DateIn is a value to be checked as a valid date.
' If it is a valid date, DateOut is set to its value and the function
' returns True.
' Excel misinterprets dates such as "4/14/11" as 14 April 2011. This routine
' checks for such dates and, if necessary, changes them to an unambiguous
' format before calling IsDate and DateValue.
Dim DatePart() As String
Dim MonthNum As Long
Const MonthAbbr As String = "janfebmaraprmayjunjulaugsepoctnovdec"
' Replace popular delimiters with Microsoft standard
DateIn = Replace(DateIn, "-", "/")
DateIn = Replace(DateIn, "\", "/")
DatePart = Split(DateIn, "/")
If UBound(DatePart) = 2 Then
' DateStg is three values separated by delimiters
' Check middle part
If IsNumeric(DatePart(1)) Then
MonthNum = Val(DatePart(1))
If MonthNum >= 1 And MonthNum <= 12 Then
' Middle part could be numeric month
' Convert to format Excel does not misinterpret
'Debug.Assert False
DatePart(1) = Mid(MonthAbbr, ((MonthNum - 1) * 3) + 1, 3)
DateIn = Join(DatePart, "-")
If IsDate(DateIn) Then
DateOut = DateValue(DateIn)
MyDateValue = True
Exit Function
End If
Else
' Middle part cannot be a month
'Debug.Assert False
MyDateValue = False
Exit Function
End If
Else
'Debug.Assert False
' The middle part is not a number. It could be a month abbreviation
MonthNum = InStr(1, MonthAbbr, LCase(DatePart(1)))
If MonthNum = 0 Then
' The middle portion is neither a month number nor a month abbreviation
Debug.Assert False
MyDateValue = False
Else
' The middle portion is a month abbreviation.
' Excel will handle date correctly
'Debug.Assert False
MonthNum = (MonthNum - 1) / 3 + 1
DateIn = Join(DatePart, "-")
If IsDate(DateIn) Then
'Debug.Assert False
DateOut = DateValue(DateIn)
MyDateValue = True
Exit Function
End If
End If
End If
Else
' Debug.Assert False
' Use IsDate for other formats
If IsDate(DateIn) Then
' Debug.Assert False
DateOut = DateValue(DateIn)
MyDateValue = True
Exit Function
Else
' Debug.Assert False
MyDateValue = False
End If
End If
End Function