I am trying to generate a table that contains all quarters based on a start date and an end date. I wrote already a function but unfortunately is not calculating the quarters correctly. For example I have:
- start date: 01.06.2018
- end date: 01.03.2019
My function generates Q2, Q3, Q4 and normally and correctly should generate Q2, Q3, Q4, Q1.
Does anyone have sugestion?
Thank you!
Here is my function:
Private Function calculateQuartars(ByVal startDate As Date, ByVal endDate As Date) As Collection
Dim iDate As Date, i As Integer
Dim quartal As String
Dim quartalListe As Collection
iDate = startDate
i = 0
Set quartalListe = New Collection
If (IsDate(startDate) And IsDate(endDate)) Then
Do
quartal = "Q" & DatePart("q", iDate) & " " & DatePart("yyyy", iDate)
quartalListe.Add quartal, "Q" & i
iDate = DateAdd("m", 3, iDate)
i = i + 1
Loop While iDate < endDate
Else
quartal = ""
quartalListe.Add quartal, "Q" & i
End If
Set calculateQuartars = quartalListe
End Function
The problem is with the below line
Loop While iDate < endDate
Your loop exits if the dates are equal
Change it to
Loop While iDate <= endDate
I solved it!
If (IsDate(startDate) And IsDate(endDate)) Then
Do
quartal = "Q" & DatePart("q", iDate) & " " & DatePart("yyyy", iDate)
iDate = DateAdd("m", 1, iDate)
If LastQuartal = quartal Then
Else
quartal = "Q" & DatePart("q", iDate) & " " & DatePart("yyyy", iDate)
quartalListe.Add quartal
LastQuartal = quartal
End If
Loop While iDate <= endDate
Related
I am trying to list the dates between two given months: a) 1/1/2021; b) 6/1/2021 in format: 01.2021; 02.2021; 03.2021; 04.2021; 05.2021; 06.2021
I was able to find and use this UDF:
Function MONTHRANGE(startDate As Date, endDate As Date, _
Optional Delim As String = "; ", _
Optional dFormat As String = "MM.YYYY") As String
MONTHRANGE = Join(Evaluate("TRANSPOSE(TEXT(ROW(" & CLng(startDate) & ":" & CLng(endDate) & ")," & Chr(34) & dFormat & Chr(34) & "))"), Delim)
End Function
The output of this is repeated dates (for each day of the month) in the format I want - how can I return just the unique values (one - per month)?
Something like the following gets the job done:
Option Explicit
Private Sub Test()
Debug.Print GetMonths(CDate("1/1/2021"), CDate("6/1/2021"))
End Sub
Private Function GetMonths(ByVal StartDate As Date, ByVal EndDate As Date) As String
Do While StartDate <= EndDate
GetMonths = GetMonths & Format(Month(StartDate), "00") & "." & Year(StartDate) & "; "
StartDate = DateAdd("m", 1, StartDate)
Loop
GetMonths = Left(GetMonths, Len(GetMonths) - 2)
End Function
Download for Sheet to better understand.
https://www.dropbox.com/s/urncoww8prj6rc1/AccountabilityScorecardDigital.xlsm?dl=0
I am creating a workbook that has auto-creating sheets. Each sheet has the same data with the exception of the dates. I simply need the one cell "A1" to auto-change it's name to the next date range.
For Example: Sheet1 Cell A1 "DEC 11-15 2017"
Copied : Sheet2 Cell A1 "Dec 18-22 2017"
Copied2 : Sheet3 Cell A1 "Dec 25-29 2017"
Copied3 : Sheet4 Cell A1 "Jan 01-05 2017"
It has to follow this naming convention so that the rest of the sheet updates accordingly.
Here you go.
Just use the GetProperWeekName function and feed it whatever you want.
For example, GetProperWeekName("DEC 11-15 2017", 7)
Will Return:
DEC 18-22 2017
You can add days, months, or years by using the optional parameters.
To add a week, you would use 7 as I did in my example.
When you create your new sheet, just update A1 by doing something like:
Range("A1") = GetProperWeekName(Range("A1"),7)
Function GetProperWeekName(TheWeek As Variant, Optional DaysToAdd = 0, Optional MonthsToAdd = 0, Optional YearsToAdd = 0) As String
Dim TheDate As Date
TheDate = DateValue(Trim(Left(TheWeek, WorksheetFunction.Find("-", TheWeek) - 1)))
If DaysToAdd <> 0 Then TheDate = DateAdd("d", DaysToAdd, TheDate)
If MonthsToAdd <> 0 Then TheDate = DateAdd("m", MonthsToAdd, TheDate)
If YearsToAdd <> 0 Then TheDate = DateAdd("y", YearsToAdd, TheDate)
GetProperWeekName = UCase(Format(TheDate, "mmm")) & " " & Day(TheDate) & "-" & Day(DateAdd("d", 4, TheDate)) & " " & Year(TheDate)
End Function
Results:
If you want it to accept normal dates and format them, it's easier:
Function GetProperWeekName(TheDate As Date, Optional DaysToAdd = 0, Optional MonthsToAdd = 0, Optional YearsToAdd = 0) As String
If DaysToAdd <> 0 Then TheDate = DateAdd("d", DaysToAdd, TheDate)
If MonthsToAdd <> 0 Then TheDate = DateAdd("m", MonthsToAdd, TheDate)
If YearsToAdd <> 0 Then TheDate = DateAdd("y", YearsToAdd, TheDate)
GetProperWeekName = UCase(Format(TheDate, "mmm")) & " " & Day(TheDate) & "-" & Day(DateAdd("d", 4, TheDate)) & " " & Year(TheDate)
End Function
How to update your sheet and date ranges properly:
Sub UpdateSheet()
ActiveSheet.Copy After:=Sheets(ActiveSheet.Name)
ActiveSheet.Name = GetProperWeekName(Range("A1"), 7)
Range("A1") = GetProperWeekName(Range("A1"), 7)
End Sub
QHarr's Padding Addition:
Function GetProperWeekName(TheWeek As Variant, Optional DaysToAdd = 0, Optional MonthsToAdd = 0, Optional YearsToAdd = 0) As String
Dim TheDate As Date
TheDate = DateValue(Trim(Left(TheWeek, WorksheetFunction.Find("-", TheWeek) - 1)))
If DaysToAdd <> 0 Then TheDate = DateAdd("d", DaysToAdd, TheDate)
If MonthsToAdd <> 0 Then TheDate = DateAdd("m", MonthsToAdd, TheDate)
If YearsToAdd <> 0 Then TheDate = DateAdd("y", YearsToAdd, TheDate)
GetProperWeekName = UCase(Format(TheDate, "mmm")) & " " & Format(Day(TheDate), "00") & "-" & Format(Day(DateAdd("d", 4, TheDate)), "00") & " " & Year(TheDate)
End Function
guys sorry I don't really know how to title my question. and not so good in English.
but here's my problem:
I want to fetch the birthdays of employees. from a specified month
eg: For the month of "August" I want to fetch data from dates 14 - 20
I'm having a hard time because each has different birth years.
Here is what i have tried. but doesn't work, i also search the internet but don't have a single clue.
Dim monthName As String = cb_month.Text 'from combobox that has list of months
Dim monthNumber = DateTime.ParseExact(monthName, "MMMM", CultureInfo.CurrentCulture).Month
Dim fromday = CInt(cb_dayfrom.Text)
Dim todate = cb_dayto.Text
' Here's my query
query = "SELECT empID AS 'ID', Name, Cast(Birthday AS DATE) FROM empInfo BETWEEN '%" & monthNumber & "-" & fromday.ToString & "%' AND '%" & monthNumber & "-" & todate & "%'"
and oh, Another one problem is that:
the line Cast(Birthday AS DATE) returns date with Time, how do i get rid of this?
The data type of Birthday in sql is Date
At Last! found an answer to my problem ..
Dim monthNumber As Integer = DateTime.ParseExact(cb_month.Text, "MMMM", CultureInfo.CurrentCulture).Month
Dim fromdate As Integer = CInt(cb_dayfrom.Text)
Dim todate As Integer = CInt(cb_dayto.Text)
query = "SELECT empID AS 'ID', Name, CONVERT(VARCHAR(10),Birthday,101) FROM empInfo " & _
"WHERE DATEPART (month, Birthday) = " & monthNumber & _
" AND (DATEPART (day, Birthday) Between " & fromdate & " AND " & todate & ")"
I feel like this should be possible with less lines. Am I missing a VBA function to make this easier?
Sub dates()
Dim sDay As String
Dim eday As String
Quarter = DatePart(q, Date)
If Quarter = 1 Then
sDay = "1/1/" & DatePart("yyyy", Date)
eday = "3/31/" & DatePart("yyyy", Date)
ElseIf Quarter = 2 Then
sDay = "4/1/" & DatePart("yyyy", Date)
eday = "6/30/" & DatePart("yyyy", Date)
ElseIf Quarter = 3 Then
sDay = "7/1/" & DatePart("yyyy", Date)
eday = "9/30/" & DatePart("yyyy", Date)
ElseIf Quarter = 4 Then
sDay = "10/1/" & DatePart("yyyy", Date)
eday = "12/31/" & DatePart("yyyy", Date)
End If
End Sub
Yep:
Sub dates()
Dim sDay As String
Dim eDay As String
Dim Quarter As Integer
For Quarter = 1 To 4
sDay = CStr(3 * (Quarter - 1) + 1) & "/1/" & DatePart("yyyy", Date)
eDay = DateAdd("d", -1, DateAdd("q", 1, CDate(sDay)))
Debug.Print "Quarter : " & Quarter & vbTab & sDay & vbTab & eDay
Next
End Sub
Also note that in your code, q needs to be offset in double-quotes as a string literal, unless it is defined elsewhere as such.
Quarter = DatePart("q", Date)
Sub Qmonth()
Dim CMonth As Integer 'selected month from range
Dim CYear As Integer 'selected year from range
CMonth = Range("MonthO").Value
CYear = Range("YearO").Value
Select Case CMonth
Case 1 To 3
Debug.Print DateSerial(CYear, 1, 1)
Case 4 To 6
Debug.Print DateSerial(CYear, 4, 1)
Case 7 To 9
Debug.Print DateSerial(CYear, 7, 1)
Case 10 To 12
Debug.Print DateSerial(CYear, 10, 1)
End Select
End Sub
Can someone please help me to fix the formula in the sub. I need to enter dates into it via variables but it always gives me an error '13' data types
I'm talking about the bit:
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
The Sub apart from that formula works.....
Sub get_cal_weeks()
Dim weeks As Integer, i As Integer, col As String, weekstart As Date, weekend As Date, calweeks() As Variant
'start column is D
col = "D"
'get amount of weeks
weeks = countcalweeks()
'populate array calweeks
calweeks = fillcalweeks(weeks)
For i = 0 To weeks
field = i + i + 4
weekstart = calweeks(i, 0)
weekend = calweeks(i, 1)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;" >= " & weekstart & "";Rawdata!A2:A3446;" <= " & weekend & "")"
Next
End Sub
Thank you
I suggest you convert to long (or double if you need times)
Cells(5, field).FormulaLocal = "=SUMMEWENNS(Rawdata!K2:K3446;Rawdata!I2:I3446;""bezahlt"";Rawdata!A2:A3446;"">=" & CLng(weekstart) & """;Rawdata!A2:A3446;""<=" & CLng(weekend) & """)"