Problem with Week Numbers between dates on New Year - excel

Problem
The following [mcve] will output an array of arrays of week numbers between two dates. It works when both dates are on the same year, however, some years have 52 weeks and start within the last days of the last year. And others have 53 weeks.
An example of 52 weeks is the 2020 calendar:
Where the first week begins on Dec 30.
And the example of 53 weeks is the 2016 calendar:
That begins only on Jan 4th.
Code
The following code is commented and outputs an array of arrays with the week numbers.
Sub w_test()
Dim Arr() As Variant, ArrDateW() As Variant
'Initial Date
DateI = DateSerial(2015, 5, 5)
'Final Date
DateF = DateSerial(2017, 9, 20)
'Difference in weeks between DateI and DateF
weekDif = DateDiff("ww", DateI, DateF) + k - 1
i = Weekday(DateI)
d = DateI
'If not Sunday, go back to last week, to start the loop
If i <> 1 Then
d = DateAdd("d", -(i - 1), d)
End If
ReDim ArrDateW(weekDif)
ReDim Arr(2)
'Loop on all weeks between two dates to populate array of arrays
For i = 0 To weekDif
'Date
Arr(0) = d
'Trying to solve problem with New Year
If Application.WorksheetFunction.WeekNum(d) = 53 Then
flag = True
End If
If flag = False Then
Arr(1) = Application.WorksheetFunction.WeekNum(d)
Else
Arr(1) = Application.WorksheetFunction.WeekNum(DateSerial(Year(d) + 1, 1, 1))
flag = False
End If
'Year
Arr(2) = Year(d)
'Populate array of arrays
ArrDateW(i) = Arr
'Next Week Number
d = DateAdd("ww", 1, d)
Next i
'To stop with Ctrl+F8
Debug.Print d
End Sub
Question
2015 had 53 weeks, however the program outputs the following:
And between 2016 and 2017, the output is a mess:
How to fix the program to output these week numbers correctly?

I went about it somewhat differently, relying on built-in VBA functions to correctly calculate the week numbers. Read about ISO week numbers is this answer and see how I'm using the DataPart function -- though you can substitute your own version of Ron de Bruin's ISO week number function if you feel it's warranted.
A couple of quick side notes:
Always use Option Explicit
Try to use more descriptive variable names. YOU know what you're talking about NOW. In a few months, you'll struggle to remember what d and Arr mean (even if it seems obvious now). It's just a good habit and makes the code self-documenting.
My example below breaks the logic into a separate function with an optional parameter (just for fun) that would allow the caller to change the start of the week to a different day.
Code module:
Option Explicit
Sub w_test()
Dim initialDate As Date
Dim finaldate As Date
initialDate = #5/5/2015#
finaldate = #9/29/2017#
Dim weeks As Variant
weeks = WeekNumbers(initialDate, finaldate)
Debug.Print "There are " & UBound(weeks, 1) & " weeks between " & _
Format(initialDate, "dd-mmm-yyyy") & " and " & _
Format(finaldate, "dd-mmm-yyyy")
End Sub
Private Function WeekNumbers(ByVal initialDate As Date, _
ByVal finaldate As Date, _
Optional ByVal weekStart As VbDayOfWeek = vbSunday) As Variant
Dim numberOfWeeks As Long
numberOfWeeks = DateDiff("ww", initialDate, finaldate, weekStart, vbFirstFullWeek)
Dim startOfWeek As Date
If Weekday(initialDate) <> vbSunday Then
Dim adjustBy As Long
If Weekday(initialDate) > weekStart Then
adjustBy = Weekday(initialDate) - weekStart
Else
adjustBy = (Weekday(initialDate) + 7) - weekStart
End If
startOfWeek = DateAdd("d", -adjustBy, initialDate)
End If
Dim allTheWeeks As Variant
ReDim allTheWeeks(1 To numberOfWeeks)
Dim weekInfo As Variant
ReDim weekInfo(1 To 3)
Dim i As Long
For i = 1 To numberOfWeeks
weekInfo(1) = startOfWeek
weekInfo(2) = DatePart("ww", startOfWeek, weekStart, vbFirstFourDays)
weekInfo(3) = Year(startOfWeek)
allTheWeeks(i) = weekInfo
startOfWeek = DateAdd("ww", 1, startOfWeek)
Next i
WeekNumbers = allTheWeeks
End Function

Related

how can I calculate a Start and End Date based on Quarter End

I need to automatically calculate a Start Date (aka QRT_START) which is 5 years of Quarters back. A Quarter is 3 months. For example, there are 4 Quarters in a Year: March 31st, June 30th, September 30th and December 31st.

Since we are currently in November 16th 2022, the Start Date would be December 31st 2017. So depending on whatever the current date is, the Start Date needs to go back 5 years worth of Quarters.
I also need to automatically calculate the most recent End Date (aka QRT_END). So since, we are in November 16th 2022, the End Date would be the previous quarter end before today which is September 30th 2022. I have the VBA code written below, please help me fix.
Private Function getQRT_END() As String
Dim endmonth As Variant
Dim endyear As Variant
Dim Day As Variant
endmonth = Month(Date) - 1
If endmonth = 0 Then
endyear = Year(Date) - 1
endmonth = 12
day = 31
Else
endyear = Year(Date)
If endmonth = 3 Then
day = 31
Else
day = 30
End if
endmonth = “0” & endmonth
End If
getQRT_END = endyear & endmonth & day
End Function
Private Function getQRT_START() As String
Dim startmonth As Variant
Dim startyear As Variant
Dim Day As Variant
startyear = Year(Date) - 5
startmonth = Month(Date) + 2
If startmonth <10 Then
If startmonth = 3 Then
day = 31
Else
day = 30
End if
startmonth = “0” & startmonth
Else
day = 30
End If
getQRT_START = startyear & startmonth & day
End Function
Function GetQuartal(years, data)
d = DateAdd("yyyy", years, data)
q = (Month(d) + 2) \ 3
qstart = DateSerial(Year(d), (q - 1) * 3 + 1, 1)
qend = DateSerial(Year(d), q * 3 + 1, 1) - 1
GetQuartal = Array(data, d, qstart, qend)
End Function
Sub test()
Debug.Print "Date", "Date-5Y", "QY-5 Start", "QY-5 End"
For Each d In Array(Date, #2/29/2000#, #12/1/2021#, #5/5/1992#)
q = GetQuartal(-5, d)
Debug.Print q(0), q(1), q(2), q(3)
Next
End Sub
Date Date-5Y QY-5 Start QY-5 End
17.11.2022 17.11.2017 01.10.2017 31.12.2017
29.02.2000 28.02.1995 01.01.1995 31.03.1995
01.12.2021 01.12.2016 01.10.2016 31.12.2016
05.05.1992 05.05.1987 01.04.1987 30.06.1987
You can use two functions found in my library at GitHub: VBA.Date.
? DateThisQuarterUltimo(DateAdd("yyyy", -5, Date))
2017-12-31
? DatePreviousQuarterUltimo(DateAdd("yyyy", -5, Date))
2017-09-30
They are simple high-level functions:
' Returns the ultimo date of the quarter of the date passed.
'
' 2016-01-13. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DateThisQuarterUltimo( _
ByVal DateThisQuarter As Date) _
As Date
Dim Interval As String
Dim Number As Double
Dim ResultDate As Date
Number = 0
Interval = IntervalSetting(DtInterval.dtQuarter)
ResultDate = DateIntervalUltimo(Interval, Number, DateThisQuarter)
DateThisQuarterUltimo = ResultDate
End Function
' Returns the ultimo date of the quarter preceding the quarter of the date passed.
'
' 2016-01-13. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DatePreviousQuarterUltimo( _
ByVal DateThisQuarter As Date) _
As Date
Dim Interval As String
Dim Number As Double
Dim ResultDate As Date
Number = -1
Interval = IntervalSetting(DtInterval.dtQuarter)
ResultDate = DateIntervalUltimo(Interval, Number, DateThisQuarter)
DatePreviousQuarterUltimo = ResultDate
End Function
Haven't tested it completely
You can use DateSerial, DateAdd and DatePart to achieve what you want...
Option Explicit
Sub Sample()
Dim D As Date
Dim prevD As Date
D = DateSerial(2022, 11, 16)
'~~> Date 5 years years ago
prevD = DateAdd("q", -(4 * 5), D)
'~~> Last date of the quarter for a specific date
Debug.Print DateAdd("q", DatePart("q", prevD), DateSerial(Year(prevD), 1, 1)) - 1
'OUTPUT : 31-12-2017
'~~> Last date of previous quarter for a specific date
Debug.Print DateAdd("q", DatePart("q", D) - 1, DateSerial(Year(D), 1, 1)) - 1
'OUTPUT : 30-09-2022
End Sub
Changed string part to a proper date.

Divide month in week numbers with VBA

I am aware that this question has been asked in many different forms, but I would like to show my case as I have not found the perfect solution for it.
So, what I need to do is divide every month in 4 or 5 weeks, and type it into the corresponding cells.
Example :
I have tried this sample code written by User : danieltakeshi in this thread :
https://stackoverflow.com/a/47393516/11969596
But it has a flaw in it, for example if you type a date from October 2021 the result outputs 6 weeks which is impossible :
Sub WeeksInMonth()
Dim MonthYear As String, txt As String
Dim InputDate As Date, MonthYearDay As Date
Dim i As Long, intDaysInMonth As Long, j As Long
Dim MyArray As Variant
Dim arr As New Collection, a
ReDim MyArray(0 To 31)
j = 0
InputDate = ("1 / 10 / 2021") ' Date from October
MonthYear = Month(InputDate) & "/" & Year(InputDate)
intDaysInMonth = Day(DateSerial(Year(MonthYear), Month(MonthYear) + 1, 0))
For i = 1 To intDaysInMonth
MonthYearDay = DateSerial(Year(InputDate), Month(InputDate), i)
MyArray(j) = Application.WorksheetFunction.WeekNum(MonthYearDay)
j = j + 1
Next i
ReDim Preserve MyArray(0 To j - 1)
On Error Resume Next
For Each a In MyArray
arr.Add a, CStr(a)
Next
For i = 1 To arr.Count
Debug.Print arr(i)
Next
End Sub
Please help me find a solution, or tell me how I can adapt it to my current situation.
Cordially,
This routine checks for the first and last workingday (monday to friday) and then gives the calendar weeks for that date range
Option Explicit
Public Sub test_getWeeknumbersForMonth()
Dim arr As Variant
arr = getWeekNumbersForMonth("1.10.2021")
Debug.Print "1.10.2021: ", Join(arr, " - ")
arr = getWeekNumbersForMonth("1.1.2022")
Debug.Print "1.1.2022: ", Join(arr, " - ")
End Sub
Public Function getWeekNumbersForMonth(inputDate As Date) As Variant
Dim datStart As Date
datStart = getFirstWorkingDayOfMonth(inputDate)
Dim datEnd As Date
datEnd = getLastWorkingDayOfMonth(inputDate)
Dim arrWeekNumbers As Variant
ReDim arrWeekNumbers(1 To 6) 'max 6 weeks can be returned
Dim i As Long: i = 1
Dim dat As Date
dat = datStart
While dat <= datEnd
arrWeekNumbers(i) = getCalendarWeek(dat)
i = i + 1
dat = DateAdd("ww", 1, dat)
Wend
ReDim Preserve arrWeekNumbers(i - 1)
getWeekNumbersForMonth = arrWeekNumbers
End Function
Private Function getFirstWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate), 1) - 1
Dim isWorkingday As Boolean
Do
datToCheck = datToCheck + 1
isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True
getFirstWorkingDayOfMonth = datToCheck
End Function
Private Function getLastWorkingDayOfMonth(inputDate As Date) As Date
Dim datToCheck As Date: datToCheck = DateSerial(Year(inputDate), Month(inputDate) + 1, 1)
Dim isWorkingday As Boolean
Do
datToCheck = datToCheck - 1
isWorkingday = Weekday(datToCheck, vbMonday) <= 5
Loop Until isWorkingday = True
getLastWorkingDayOfMonth = datToCheck
End Function
Private Function getCalendarWeek(inputDate As Date) As Long
'european iso week - CW 1 = week with first thursday
getCalendarWeek = Application.WorksheetFunction.IsoWeekNum(inputDate)
'use weeknum-function -adjust second parameter to your needs
'https://support.microsoft.com/en-us/office/weeknum-function-e5c43a03-b4ab-426c-b411-b18c13c75340
'getCalendarWeek = Application.WorksheetFunction.WeekNum(inputDate, 2)
End Function
First, some months have dates in six weeks.
Next, VBA natively can't return the correct ISO 8601 weeknumbers:
How to get correct week number in Access
Finally, week numbers don't care about workdays or weekends. If you wish to exclude weeks that don't include specific weekdays, filter on the dates of these.

Create an array of last 12 months including month and year based on an input Month/Year in Excel VBA

Is there a way to create an array of the last 12 months (Month/Year in "mmm-yy" format) based on Month/Year in "mmm-yy" from a variable?
Use Dateadd
Sub Demo()
Dim s As String, ar, n As Integer
s = Format(Date, "mmm-yy") ' default
s = InputBox("mmm-yy", "Input mmm-yy", s)
ar = PriorYear(s)
For n = 1 To 12: Debug.Print n, ar(n): Next
End Sub
Function PriorYear(s) As Variant
Dim ar(1 To 12) As String, dt As Date, n As Integer
dt = DateValue("01-" & s)
For n = 12 To 1 Step -1
dt = DateAdd("m", -1, dt)
ar(n) = Format(dt, "mmm-yy")
Next
PriorYear = ar
End Function
Please, try the more compact version, too:
Dim arr, d As Date: d = Date 'you can choose any date you need
arr = Application.Transpose(Evaluate("TEXT(DATE(" & Year(d) - 1 & ",row(" & month(d) & ":" & month(d) + 11 & "),1),""mmm-yy"")"))
Debug.Print Join(arr, "|")
I usually post an answer if OP proves that he tried something by his own and it is good to learn that this aspect is mandatory in our community. Even explain in words what you tried. I made an exception only for the challenging sake, since the question has already been answered...
This late post demonstrates how to get the last 12 month dates via Evaluate, based on a symbolic formula syntax like
{Text(Date(StartYear,Column(StartColumn:EndColumn),1),"mmm-yyyy")}
Extra feature: The function accepts an optional argument MonthsCount changing the default value of 12 last months to any other positive value.
Public Function LastNMonths(dt As Date, Optional MonthsCount As Long = 12)
'Purpose: get 1-dim array of last 12 month dates formatted "mmm-yy")
'a) get start date
Dim StartDate As Date: StartDate = DateAdd("m", -MonthsCount + 1, dt)
Dim yrs As Long: yrs = Year(dt) - Year(StartDate)
'b) get column numbers representing months .. e.g. "J:U" or "A:L"
Dim cols As String
cols = Split(Cells(, Month(StartDate)).Address, "$")(1)
cols = cols & ":" & Split(Cells(, Month(dt) + Abs(yrs * 12)).Address, "$")(1)
'c) evaluate dates .. e.g. Text(Date(2020,Column(J:U),1),"mmm-yyyy")
LastNMonths = Evaluate("Text(Date(" & Year(StartDate) & _
",Column(" & cols & "),1),""mmm-yyyy"")")
End Function
Example call
You might want to display the resulting "flat" array based on today's date input (ending currently in Sep-2021) within the VB Editor's immediate window by a joined list
Debug.Print Join(LastNMonths(Date), "|")
returning e.g.
Oct-2020|Nov-2020|Dec-2020|Jan-2021|Feb-2021|Mar-2021|Apr-2021|May-2021|Jun-2021|Jul-2021|Aug-2021|Sep-2021

Excel: Display collection of month names generated from start and end date?

I am trying to generate a table to record articles published each month. However, the months I work with different clients vary based on the campaign length. For example, Client A is on a six month contract from March to September. Client B is on a 12 month contract starting from February.
Rather than creating a bespoke list of the relevant months each time, I want to automatically generate the list based on campaign start and finish.
Here's a screenshot to illustrate how this might look:
Below is an example of expected output from the above, what I would like to achieve:
Currently, the only month that's generated is the last one. And it goes into A6 (I would have hoped A5, but I feel like I'm trying to speak a language using Google Translate, so...).
Here's the code I'm using:
Sub CreateReport()
Dim uniqueMonths As Collection
Set uniqueMonths = New Collection
Dim dateRange As Range
Set dateRange = Range("B2:C2")
On Error Resume Next
Dim currentRange As Range
For Each currentRange In dateRange.Cells
If currentRange.Value <> "" Then
Dim tempDate As Date: tempDate = CDate(currentRange.Text)
Dim parsedDateString As String: parsedDateString = Format(tempDate, "MMM")
uniqueMonths.Add item:=parsedDateString, Key:=parsedDateString
End If
Next currentRange
On Error GoTo 0
Dim uniqueMonth As Variant
For Each uniqueMonth In uniqueMonths
Debug.Print uniqueMonth
Next uniqueMonth
Dim item As Variant, currentRow As Long
currentRow = 5
For Each item In uniqueMonths
dateRange.Cells(currentRow, 0).Value = item
currentRow = currentRow + 1
Next item
End Sub
User defined function via Evaluate
Simply enter =GetCampaignMonths(A2,B2) into cell A5.
If you don't dispose of the newer dynamic versions 2019+/MS365, it's necessary to enter a CSE (Ctrl+Shift+Enter) to finish an {array formula}:
Explanation
Basically this displays all results as dynamic (spill) range, profiting from an evaluation of a code one liner ...
e.g. Jan..Dec (12 months represented by column addresses)*
=TEXT(DATE(0,Column(A:L),1),"mmmm")
If you want to include further years, the udf simply adds the years difference (section a) multiplied by 12 to the column numbers (c.f. section b).
The evaluation of the DATE() function (c.f. section c) gets even successive years correctly, TEXT() returns the (English) months names formatted via "mmmm".
Public Function GetCampaignMonths(StartDate As Date, StopDate As Date)
'Purpose: get vertical 2-dim array of month names
'a) get years difference
Dim yrs As Long: yrs = Year(StopDate) - Year(StartDate)
'b) get column numbers representing months
Dim cols As String
cols = Split(Cells(, month(StartDate)).Address, "$")(1)
cols = cols & ":" & Split(Cells(, month(StopDate) + Abs(yrs * 12)).Address, "$")(1)
'c) evaluate dates
Dim months
months = Evaluate("Text(Date(0,Column(" & cols & "),1),""mmmm"")")
GetCampaignMonths = Application.Transpose(months)
End Function
Make an Array with the month names and then loop trough it accordting to initial month and end month:
Sub test()
Dim IniDate As Date
Dim EndDate As Date
Dim Months As Variant
Dim i As Long
Dim zz As Long
IniDate = CDate(Range("A2").Value)
EndDate = CDate(Range("b2").Value)
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
zz = 5
For i = Month(IniDate) - 1 To Month(EndDate) - 1 Step 1
Range("A" & zz) = Months(i)
zz = zz + 1
Next i
Erase Months
End Sub
For this code to work, both dates must be recognized as dates properly. Make sure of that or it won't work.
IMPORTANT: This will work only with dates in same year, unfortunately... I noticed that right now.
UPDATE: You can benefit from DateAdd and DateDiff to make a code so it works even in different years :)
DateAdd
function
DateDiff
Function
Sub test2()
Dim IniDate As Date
Dim EndDate As Date
Dim Months As Variant
Dim i As Long
Dim zz As Long
Dim TotalMonths As Byte
IniDate = CDate(Range("A2").Value)
EndDate = CDate(Range("b2").Value)
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
TotalMonths = DateDiff("m", IniDate, EndDate, vbMonday)
zz = 5
For i = 0 To TotalMonths Step 1
Range("A" & zz).Value = Months(Month(DateAdd("m", i, IniDate)) - 1)
zz = zz + 1
Next i
Erase Months
End Sub
You can also do this with functions, no VBA required:
Office 365
A5: =EOMONTH(Campaign_Start,SEQUENCE(1+DATEDIF(Campaign_Start,Campaign_End,"m")+(DAY(Campaign_End)<DAY(Campaign_Start)),,0))
and the results will SPILL down as far as needed.
Format the cells as mmm
If you do not have Office 365, then try:
=EOMONTH(Campaign_Start,-1+ROW(INDEX($A:$A,1):INDEX($A:$A,1+DATEDIF(Campaign_Start,Campaign_End,"m")+(DAY(Campaign_End)<DAY(Campaign_Start)))))
If your version of Excel does not have dynamic arrays where the results SPILL, you will need to enter the formula in the individual cells as an array, and it would require further modification.
As replay to #T.M. nice piece of code. The version using Row Evaluation:
Function GetCampaignMnths(StartDate As Date, StopDate As Date)
'Purpose: get vertical 2-dim array of month names
'b) get rows numbers representing months
Dim monthsNo As Long, rows As String
monthsNo = DateDiff("m", StartDate, StopDate, vbMonday)
rows = Month(StartDate) & ":" & monthsNo + Month(StartDate)
'c) evaluate dates
Dim months
months = Evaluate("Text(Date(0,row(" & rows & "),1),""mmmm"")")
GetCampaignMnths = months
End Function
It can be easily tested using the next sub:
Sub testGetCampaignMohths()
Dim arr
arr = GetCampaignMnths("01.03.2021", "01.08.2022") 'use here date recognized by yor localization. Or build them using DateSerial
Debug.Print Join(Application.Transpose(arr), "|")
End Sub
Assuming A2 & B2 are already dates,
Sub CreateReport()
Dim mth as Date, endmth as Date, orow as Integer
mth = worksheetfunction.eomonth(activesheet.cells(2,1).value,0)
endmth = worksheetfunction.eomonth(activesheet.cells(2,2).value,0)
orow = 5
Do
Activesheet.cells(orow,1).value = worksheetfunction.min(activesheet.cells(2,2).value,mth)
' Activesheet.cells(orow,1).numberformat = "mmm" 'uncomment for automatic formatting
orow = orow + 1
mth = worksheetfunction.eomonth(mth,1)
Loop While mth <= endmth
End Sub
This actually puts dates into your output column which can custom format as "mmm" if necessary. If you decide you actually just want text in those columns then just wrap the min(endmth,mth) in a worksheetfunction.text function with a "mmm" format.
Please, try the next code:
Sub GenerateMonthsL()
Dim sh As Worksheet, firstM As Long, lastM As Long, arrD, arrProj, i As Long, k As Long
Set sh = ActiveSheet
firstM = month(sh.Range("A2").Value2)
lastM = month(sh.Range("B2").Value2)
arrD = Split("Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Dec", ",")
ReDim arrProj(lastM - firstM + 1)
For i = firstM - 1 To lastM - 1
arrProj(k) = arrD(i): k = k + 1
Next
ReDim Preserve arrProj(k - 1)
sh.Range("A5").Resize(UBound(arrProj) + 1, 1).value = Application.Transpose(arrProj)
With sh.Range("A4:B4")
.value = Array("Months", "Articles Published")
.Font.Bold = True
.Interior.Color = 14998742
.EntireColumn.AutoFit
End With
End Sub
If you would rather avoid VBA entirely, Excel's array functions let you do this using spreadsheet formulae (if your version of Excel is recent enough).
Put this formula in Cell A5 (assuming start date in A2, and end date in B2):
=LET(mnths,1+(12*YEAR(B2)+MONTH(B2)-(12*YEAR(A2)+MONTH(A2))),s,SEQUENCE(mnths),TEXT(DATE(YEAR(A2),MONTH(A2)+(s-1),1),"mmm"))
If you have more than a year, you can amend the TEXT format string to "mmm-yy".

Cleaning Data: "Mon - Fri" or "Sat through Thurs"

I have an excel spreadsheet with 50000 rows of business hours data (in every conceivable format):
THU 4P-9P F 9A-9P SAT,SUN 9A-6P
WED & THU 10A - 3P FRI 10A - 1P
MON - FRI 6P - 10P
M - SA 9A - 9P
SUN-SAT 9-5
SU - SA 8A- 10P
TUE - FRI 10A - 6P SAT 12P - 4P
MON - FRI 730A-4P / SAT 9A-12P
SUN 6A-5P / M-F 6A-9P / SAT 5A-9P
I need to convert it to something like:
Days Open A Week: 2
Hours Open a Week: 15
I thought of doing:
Business Hours Sunday
WED 1P - 5P THU - SA BY APPT =ISNUMBER(SEARCH("Sun",A1)) # returns True.
for each day, but I'm wondering if there is an easier way to clean this data other than hard coding every possibility.
Thank you!
Here's some VBA that worked on the sample data provided. It almost certainly won't work on a larger sample, but it's a start.
Public Function DaysAndHours(ByVal sInput As String)
Dim vaTokens As Variant
Dim i As Long, j As Long
Dim vaSeps As Variant
Dim dtTime As Date, dtStart As Date, dtEnd As Date
Dim dHours As Double, dTodayHours As Double
Dim lStartDay As Long, lEndDay As Long
Dim bThrough As Boolean
Dim dcDay As Scripting.Dictionary
Dim vItem As Variant
Set dcDay = New Scripting.Dictionary
'These are all the characters that split the data
'as you discover more characters, add them here
vaSeps = Split("- , / &")
'If the data has times like 730, Excel can't tell it's a time
'so this adds a colon before 30 and 15 assuming it's unlikely
'anyone would open or close on other than a quarter hour
'then if there was already a colon there, it would be doubled
'so remove double colons
sInput = Replace(sInput, "30", ":30")
sInput = Replace(sInput, "15", ":15")
sInput = Replace(sInput, "::", ":")
'Some separators have spaces around them and some don't. This changes
'all separators so they have spaces. This is so our split creates
'proper tokens
For j = LBound(vaSeps) To UBound(vaSeps)
sInput = Replace(sInput, vaSeps(j), Space(1) & vaSeps(j) & Space(1))
Next j
'If the separators already had spaces around them, they would be
'doubled. Trim removes double spaces
sInput = Application.Trim(sInput)
vaTokens = Split(sInput, Space(1))
'Assume the first token is a day, and put it in the
'dictionary at zero hours
lStartDay = GetDayFromInit(vaTokens(LBound(vaTokens)))
dcDay.Add lStartDay, 0
For i = LBound(vaTokens) + 1 To UBound(vaTokens)
'Some separators are "through" meaning that all the days in between
'the two days are included. Other separators just list discrete days
If IsSep(vaTokens(i), vaSeps) Then
Select Case vaTokens(i)
Case "-"
bThrough = True
Case Else
bThrough = False
End Select
Else
'Excel won't convert a straight number to a time, so this
'adds :00 to make it look like a time
If IsNumeric(vaTokens(i)) Then
vaTokens(i) = vaTokens(i) & ":00"
End If
'Try to change the token into a time. If it
'works, we're dealing with times, otherwise days
On Error Resume Next
dtTime = TimeValue(vaTokens(i))
On Error GoTo 0
If dtTime > 0 Then 'the current token is a time
If dtStart > 0 Then 'we've already converted a time, so this must be the end time
dtEnd = dtTime
If dtEnd < dtStart Then dtEnd = dtEnd + TimeSerial(12, 0, 0) 'make sure the end time is after the start time
dTodayHours = dtEnd - dtStart 'compute the hours open
'For every day that we haven't filled a time, put this time
For j = 0 To dcDay.Count - 1
If dcDay.Items(j) = 0 Then
dcDay.Item(dcDay.Keys(j)) = dTodayHours
End If
Next j
dtStart = 0: dtEnd = 0: dtTime = 0 'reset
bThrough = False 'reset
Else 'We haven't already filled a time, so this must be the start time
dtStart = dtTime
End If
Else 'the current token isn't a time, it must be day
'we've encountered a through separator, so we've alreay got a start day
'and this token is the end day
If bThrough Then
lEndDay = GetDayFromInit(vaTokens(i))
'If the days are in the right order, just add them
'in order to the dictionary
If lStartDay < lEndDay Then
For j = lStartDay To lEndDay
If Not dcDay.Exists(j) Then
dcDay.Add j, 0
End If
Next j
Else 'Days are in the wrong order (where Sunday = 1)
For j = 1 To lEndDay
If Not dcDay.Exists(j) Then
dcDay.Add j, 0
End If
Next j
For j = lStartDay To 7
If Not dcDay.Exists(j) Then
dcDay.Add j, 0
End If
Next j
End If
Else 'We haven't encountered a through operator, so this is a lone day or the first of a range
lStartDay = GetDayFromInit(vaTokens(i))
If Not dcDay.Exists(lStartDay) Then
dcDay.Add lStartDay, 0
End If
End If
End If
End If
Next i
DaysAndHours = dcDay.Count & " days, " & Application.Sum(dcDay.Items) * 24 & " hours"
End Function
Public Function GetDayFromInit(ByVal sInit As String) As Long
Dim vaDays As Variant
Dim i As Long
vaDays = Split("SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY")
For i = 0 To 6
If UCase(sInit) = Left$(vaDays(i), Len(sInit)) Then
GetDayFromInit = i + 1
Exit For
End If
Next i
End Function
Public Function IsSep(ByVal sChar As String, ByRef vSeps As Variant) As Boolean
IsSep = InStr(1, Join(vSeps), sChar)
End Function

Resources