i am completely new to VBA in Excel and trying to learn as much as I can as fast as I can so it can help me with my master thesis.
I have a fairly large dataset consisting of daily stock returns. I would like to copy the last day of each month into a new sheet but I am stuck in doing so.
Currently I am using a code to generate a column of dates based on column A in a different worksheet. I have provided this code below but it does not actually filter, it just generates the first and 15th day of the next month.
Private Sub Listmonths(strWksResult As String, strWksData As String)
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
FirstDate = Worksheets(strWksData).Range("A21").Value
LastDate = Worksheets(strWksData).Range("A4696").Value
NextDate = FirstDate
Worksheets(strWksResult).Range("A2").Select
'selection of columns within one row
Do Until NextDate >= LastDate
ActiveCell.Value = NextDate
ActiveCell.Offset(1, 0).Select
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
Else
NextDate = DateAdd("d", NextDate, 20)
NextDate = DateSerial(Year(NextDate), Month(NextDate), 1)
End If
Loop
End Sub
Any help would be greatly appreciated!
Thanks in advance
Replace these lines:
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
Else
NextDate = DateAdd("d", NextDate, 20)
NextDate = DateSerial(Year(NextDate), Month(NextDate), 1)
End If
with
Select Case Day(NextDate)
Case 1
NextDate = NextDate + 14
Case 15
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 1, 1) - 1
Case Else
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 1, 1)
End Select
To get (1) the first day of each month, (2) the 15th of each month, and (3) the last day of each month.
If you are merely looking for the last day of each month then you should only use
NextDate = DateSerial(Year(NextDate), Month(NextDate) + 2, 1) - 1
The last day of each month is one day before the first day of the next month. This way it's easy to write either VBA code or an Excel Formula.
If the original date is d, then
DateSerial(Year(d), Month(d) + 1, 1) - 1
is the last day of the month that contains d.
Update
I didn't know which part of the problem is obvious to you. Here is a full version of the code (it found it better to build it from scratch):
Option Explicit
Private Sub Listmonths(strWksResult As String, strWksData As String)
Dim rngResult As Range: Set rngResult = Worksheets(strWksResult).Range("A1")
Dim rngDates As Range: Set rngDates = Worksheets(strWksData).Range("A21:A4696") ' This should be changed to a Named Range or calculation based on UsedRange
Dim rr As Long: rr = 1
Dim r As Long: For r = 1 To rngDates.Rows.Count
Dim varDate As Variant: varDate = rngDates.Cells(r, 1).Value ' In case of performance problems read the whole range at once
If IsDate(varDate) Then
If varDate = DateSerial(Year(varDate), Month(varDate) + 1, 1) - 1 Then
rngResult.Cells(rr, 1).Value = varDate
rngResult.Cells(rr, 2).Value = rngDates.Cells(r, 2).Value ' In case of performance problems write the whole range at once
rr = rr + 1
End If
End If
Next r
End Sub
Related
I am trying to write a script that searches a list of dates, and identifyies how long date gaps are. I'm new to VBA, and this may be completely wrong, but after referencing several sites, here is what I came up with:
Sub IdentifyGaps()
Dim startdate As Date 'first date in column
Dim enddate As Date 'last date in column
Dim ust As Date 'first date of unemployment
Dim i As Long
ust = ActiveCell.Offset(1, 0).Value
With Sheet6
startdate = [A1]
enddate = .Cells(.Rows.Count, "A").End(xlUp).Value
For i = startdate To enddate
If ust <> DateAdd("d", 1, i) Then
Sheet6.[C1].Value = DateDiff("d", i, ust)
End If
Next i
End With
End Sub
I'm not receiving an error, but the macro is not working properly. Right now, it's returning -43074 when it should be returning 15. Any help would be much appreciated!
Here is a screenshot of the data, with the lone date gap it should pick up.
Sub IdentifyGaps()
Dim ws As Worksheet
Dim Date1 As Long, Date2 As Long, Gap As Long, lRow As Long
Set ws = Sheet6
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row
For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
Date1 = ws.Cells(x, 1).Value
Date2 = ws.Cells(x + 1, 1).Value
Gap = DateDiff("d", Date1, Date2)
If Gap > 1 Then
ws.Range("C" & lRow).Value = Gap
lRow = lRow + 1
End If
Next x
Looking at my calendar, I believe your expected result should actually be 17, not 15. This code will return the gap value as a Long value with which you can do whatever you want.
'Reads a column of dates and returns the length of the first gap found
Function IdentifyGaps() As Long
Dim StartDate As Date
Dim EndDate As Date
'This Variable is not needed for this solution, it is instead replaced by Gap
'Dim ust As Date
Dim Gap As Long
'Read cell values into an array for more efficient operation
Dim ReadArray() As Variant
ReadArray = Sheet6.Range("A1").CurrentRegion
Dim LastRow As Long
LastRow = UBound(ReadArray, 1)
StartDate = ReadArray(1, 1)
EndDate = ReadArray(LastRow, 1)
'ThisDate and PreviousDate are declared explicitly to highlight program flow
Dim Row As Long
Dim ThisDate As Date
Dim PreviousDate As Date
For Row = 2 To UBound(ReadArray, 1)
ThisDate = ReadArray(Row, 1)
PreviousDate = ReadArray(Row - 1, 1)
Gap = ThisDate - PreviousDate
If Gap > 1 Then Exit For
Gap = 0
Next Row
IdentifyGaps = Gap
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProveIt()
Debug.Print IdentifyGaps
End Sub
I managed to use the following formula to calculate the net working days between two dates.The problem is i would like to make it possible for the user to enter what days of the week the person works in another cell and automatically update the formula. Just to make it more user friendly, and prevent the user from messing with the formula. Is there anyway to enter the string(12345) in another cell and have the formula update automatically?
Thanks in advance
Option Explicit
'
' This function tells you how many working days are there between 2 given dates.
' You can use this to calculate working days in countries where saturday and sunday are
' not usually holidays.
'
Function NetWorkingDays(sDateRng As Range, eDateRng As Range, workingDays As String, _
Optional HolidayRng As Range) As Long
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356")
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2
'
' e.g. use: =NetWorkingDays($A$1,$A$2,"12356",$H$2:$H$50)
' will tell you the count of mondays, tuesdays, wednesdays, fridays and saturdays
' between the dates in $A$1 and $A$2, excluding any holidays (listed as dates) in
' the range $H$2:$H$50
'
' You can also count the number of individual days between dates:
' =NetWorkingDays($A$1,$A$2,"2")
' will tell you the number of tuesdays between those two dates
'
Dim sDate As Date, eDate As Date, Holidays() As Variant
Dim nHolidays As Long
Dim totalDays, startDay As Long, endDay As Long
Dim totWeeks As Long, extraDays As Long
Dim curWeekday As Long
Dim i, retVal As Long
'
If (Not IsDate(sDateRng.Value)) Then
sDate = 0#
Else
sDate = sDateRng.Value
End If
'
If (Not IsDate(eDateRng.Value)) Then
eDate = 0#
Else
eDate = eDateRng.Value
End If
'
If (Not HolidayRng Is Nothing) Then
nHolidays = HolidayRng.Cells.Count
ReDim Holidays(0 To nHolidays - 1)
Holidays = HolidayRng.Value2 ' CAREFUL - this automatically assumes dates in the range!
Else
nHolidays = 0
End If
'
totalDays = eDate - sDate + 1
startDay = Weekday(sDate, vbMonday)
endDay = Weekday(eDate, vbMonday)
'
' First calculate the number of whole weeks in the date span.
' Whole weeks are defined as all weeks that start on Monday and
' end on Sunday.
'
If (startDay = 1) Then
If (endDay = 7) Then
extraDays = 0
Else
extraDays = 7 - endDay
End If
Else
If (endDay = 7) Then
extraDays = 7 - startDay + 1
Else
extraDays = 7 - startDay + 1 + endDay
End If
End If
totWeeks = (totalDays - extraDays) / 7
'
' Now determine how many "extra" days are on either side of
' the whole weeks. Include only those "extra" days that are
' a part of the "workingDays" string.
'
extraDays = 0
If (startDay <> 1) Then
For i = startDay To 7
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
If (endDay <> 7) Then
For i = 1 To endDay
If (InStr(workingDays, CStr(i)) > 0) Then
extraDays = extraDays + 1
End If
Next i
End If
'
retVal = totWeeks * Len(workingDays) + extraDays
'
' Now subtract out the holidays if applicable to the period in question
'
If (nHolidays > 0) Then
For i = LBound(Holidays) To UBound(Holidays)
If (InStr(workingDays, Weekday(Holidays(i, 1), vbMonday)) > 0 And _
Holidays(i, 1) >= sDate And Holidays(i, 1) <= eDate) Then
retVal = retVal - 1
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was removed: it is a " & Format(Holidays(i, 1), "dddd")
Else
'Debug.Print Format(Holidays(i, 1), "dd mmm, yyyy") & " was not removed: it is a " & Format(Holidays(i, 1), "dddd")
End If
Next i
End If
'
NetWorkingDays = retVal
End Function
I am a newbie in vba and I am trying to get in vba all dates between 2 dates, for example I will call the function with the parameters 01-01-2015 and 15-01-2015, and I will get in return an array with all the dates possibles, i.e :
01-01-2015
02-01-2015
03-01-2015
.....
15-01-2015
I didn't find the answer on the forums, so thanks in advance for your help.
you can simply convert the dated in long and make loop(+1) and get all dated between 2 dates(convert that to date again)
Sub Calling()
Dim test
test = getDates(#1/25/2015#, #2/5/2015#)
End Sub
Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(1 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(StartDate)
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
ClearMemory:
If IsArray(varDates) Then Erase varDates
lngDateCounter = Empty
End Function
Function to get all dates from given range
Function GetDatesRange(dateStart As Date, dateEnd As Date) As Collection
Dim dates As New Collection
Dim currentDate As Date
currentDate = dateStart
Do While currentDate <= dateEnd
dates.Add currentDate
currentDate = DateAdd("d", 1, currentDate)
Loop
Set GetDatesRange = dates
End Function
Sample usage
Dim dateStartCell as Range, dateEndCell as Range
Dim allDates as Collection
Dim currentDateSter as Variant
Dim currentDate as Date
Set dateStartCell = ActiveSheet.Cells(3, 3)
Set dateEndCell = ActiveSheet.Cells(3, 6)
Set allDates = GetDatesRange(dateStartCell.Value, dateEndCell.Value)
For Each currentDateSter In allDates
currentDate = CDate(currentDateSter)
'Do something with currentDate
Next currentDateSter
An array 'sn' containing all dates from 01-01-2015 to 15-01-2015.
Msgbox introduced to illustrate the result.
Sub M_snb()
sn = Evaluate("index(text(datevalue(""01-01-2015"")+row(1:" & DateDiff("d", CDate("01-01-2015"), CDate("15-01-2015")) & ")-1,""dd-mm-yyyy""),)")
MsgBox sn(1, 1) & vbLf & sn(2, 1) & sn(UBound(sn), 1)
End Sub
Maybe this.
Function udf_Array_of_Dates(dtSTART As Date, dtEND As Date, rDATEs As Range)
Dim dt() As Date, r As Range, d As Long
For Each r In rDATEs
If r.Value >= dtSTART And r.Value <= dtEND Then
d = d + 1
ReDim Preserve dt(1 To d)
dt(d) = r.Value
End If
Next r
udf_Array_of_Dates = dt
End Function
Proof & syntax:
If you just want to print the dates between two date in excel then my Suggestion is to you try below the code.
Sub DateFill()
Dim Start_Date As Date
Dim End_Date As Date
Dim Number_Of_Days As Integer
Start_Date = InputBox(prompt:="Enter the Start Date", Title:="Date Print", Default:="3/1/2013")
End_Date = InputBox(prompt:="Enter the End Date", Title:="Date Print", Default:="3/23/2013")
Range("A1").Value = Start_Date
'Range("B1").Value = End_Date
Range("A1").Select
Number_Of_Days = DateDiff("d", Start_Date, End_Date) ' Return Day
Number_Of_Days = Number_Of_Days + 1
'Range("C1").Formula = "=DATEDIF(A1, B1, ""D"") "
Selection.AutoFill Destination:=Range("A1:A" & Number_Of_Days), Type:=xlFillDefault
Range("A1:A" & Number_Of_Days).Select
End Sub
Here you have avoid the use of Loop that save the execution time.
Ive searched for several hours and since my knowledge of VBA is very limited I'm at a loss. I have an "Inventory Total" for several different items going across the top row (Row B) which is updated by imputing a positive or negative amount on a line below it along with the date of update at the far left (column 1). I have another book that needs to keep track of only the subtractions made to each field by the month.
I already have an (auto_run) macro, so I plan to add this to it. It needs to check today's date and if its the first of the month take the total of all negative numbers (per column) for THAT MONTH ONLY and add it to the top line of the other book.
The part I need to know is how to get the totals per month in VBA.
This is what I'm using to to check today's date:
If Date - Day(Date) + 1 = Date - Day(Date) + 1 And Range("'Monthly Office Inventory'!A2") <> Date - Day(Date) + 1 Then
I'm thinking something like a nested IF check for a value between the first of last month and the end of last month, using the date functions.
Help please?
Sub Datetest()
Dim i As Integer
Dim x As Integer
Dim rng1 As Range
Dim rng2 As Range
Dim crninvbk As Worksheet
Dim mntlisbk As Worksheet
Set crninvbk = Worksheets("Current Office Inventory")
Set mntlisbk = Worksheets("sheet1")
PreviousMonth = DateAdd("m", -1, Date)
Negativemonthly = 0
For x = 2 To 23
For i = 3 To 100
If crninvbk.Cells(i, 1).value >= dhFirstDayInMonth And crninvbk.Cells(i, 1).value <= dhLastDayInMonth Then
If crninvbk.Cells(i, x).value < 0 Then
Negativemonthly = Negativemonthly + crninvbk.Cells(i, x).value
End If
End If
Next i
mntlisbk.Cells(2, x) = Negativemonthly
MsgBox (Negativemonthly)
Negativemonthly = 0
Next x
MsgBox (Negativemonthly)
End Sub
Function dhFirstDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the first day in the specified month.
PreviousMonth = DateAdd("m", -1, Date)
dhFirstDayInMonth = DateSerial(Year(Date), _
Month(PreviousMonth), 1)
End Function
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
PreviousMonth = DateAdd("m", -1, Date)
dhLastDayInMonth = DateSerial(Year(Date), _
Month(PreviousMonth) + 1, 0)
End Function
Previously I found some VBA code done by Andy Brown that generates a list and makes each date the first or 15th for another user. I have tried to adjust this code to my needs but I'm struggling. Currently the code, once run, is just putting in the same date over and over and I have to end Excel.
Sub GenerateDates()
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
FirstDate = Range("A1").Value
LastDate = Range("a2").Value
NextDate = FirstDate
Range("B1").Select
Do Until NextDate >= LastDate
ActiveCell.Value = NextDate
ActiveCell.Offset(1, 0).Select
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
Else
NextDate = DateAdd("d", NextDate, 20)
NextDate = DateSerial(Year(NextDate), Month(NextDate), 1)
End If
Loop
Previous code I based my model upon is listed above and my, most likely terrible code, is below:
Sub GenerateDates()
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
FirstDate = Range("startdate").Value
LastDate = Range("enddate").Value
NextDate = FirstDate
Range("tripdays").Select
'selection of columns within one row
Do Until NextDate >= LastDate
ActiveCell.Value = NextDate
ActiveCell.Offset(1, 0).Select
If Day(NextDate) = 1 Then
NextDate = DateAdd("d", NextDate, 14)
End If
Loop
End Sub
What I need instead is to generate every date between the given start and end dates, instead of just the 15th and 1st. How is this done?
EDIT:
This is apparently what you need, as discussed in comments.
Sub GenerateDates()
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
FirstDate = Range("startdate").Value
LastDate = Range("enddate").Value
NextDate = FirstDate
Range("tripdays").Select
'selection of columns within one row
Do Until NextDate > LastDate
ActiveCell.Value = NextDate
ActiveCell.Offset(1, 0).Select
NextDate = NextDate + 1
Loop
End Sub
Alternatively, a For loop would do just as well.
Screenshot:
FURTHER EDIT:
Horizontal version, as requested.
Sub GenerateDatesH()
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
Dim DateOffset As Range
Dim DateIter As Date
FirstDate = Range("startdate").Value
LastDate = Range("enddate").Value
Set DateOffset = Range("tripdays")
For DateIter = FirstDate To LastDate
DateOffset.Value = DateIter
Set DateOffset = DateOffset.Offset(0, 1)
Next DateIter
End Sub
Screenshot:
Note: I've also fixed the vertical version to stop at the end date provided.
Avoid using select in code it is very inefficient :)
Sub p()
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
Dim r As Long
FirstDate = Range("A1").Value
LastDate = Range("a2").Value
r = 1
Do
FirstDate = FirstDate + 1
Cells(r, 2) = FirstDate
r = r + 1
Loop Until FirstDate = LastDate
End Sub
to do it in a row replace cells(r,2) by cells(1, r) and start r=2