Random blog posts

Creating a Date Scale in Excel

July 22, 2011 VBA 0

Sometimes you have a range of dates and you need to come up with a scale that makes sense for the dates you are trying to represent in a timeline. For example if your dates range across a year or so, you may want to break the scale into months, 2 or 3 years, quarters would be better and perhaps weeks would be best if the scale is a few months.

I came across this problem when working on a roadmap generator for Excel, and later with a port to javascript to embed it in a Google Gadget.

Once you have decided on a scale, you also need to figure out how to line up the scale at the end of the month, quarter or whatever you have chosen. Below is some useful VBA code to do all that.

Calculating the end of the ‘period’

Here is a function that will return various pieces of information a range such as the effective start date, effective finish date, number of ticks and so on given a start date and a finish date. You may find the calculations for end of quarter etc helpful, since they took me a little while to get right.

Private Function limitofScale(scaleType As String, sd As Date, fd As Date, edge As edgeTick) As Variant Dim dLastDayOfFinishScale As Date, dFirstDayOfStartScale As Variant Dim ss As String, sf As String, ticks As Single Select Case Trim(LCase(scaleType)) Case "weeks" dFirstDayOfStartScale = sd dLastDayOfFinishScale = fd + 7 - (Weekday(fd) Mod 7) ss = Format(sd, "dd-mmm-yy") sf = Format(fd, "dd-mmm-yy") ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 7 Case "months" ' 1st day of start month dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd), 1) ' last of finish month dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 1, 1) - 1 ss = Format(sd, "mmm-yyyy") sf = Format(fd, "mmm-yyyy") ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 30 Case "quarters" dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 3), 1) dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 3 - ((Month(fd) - 1) Mod 3), 1) - 1 ss = "Q" & CStr(1 + Int((Month(sd) - 1) / 3)) & Format(sd, "yyyy") sf = "Q" & CStr(1 + Int((Month(fd) - 1) / 3)) & Format(fd, "yyyy") ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 90 Case "halfyears" dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 6), 1) dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 6 - ((Month(fd) - 1) Mod 6), 1) - 1 ss = "H" & CStr(1 + Int((Month(sd) - 1) / 6)) & Format(sd, "yyyy") sf = "H" & CStr(1 + Int((Month(fd) - 1) / 6)) & Format(fd, "yyyy") ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 183 Case "years" dFirstDayOfStartScale = DateSerial(Year(sd), 1, 1) dLastDayOfFinishScale = DateSerial(Year(fd) + 1, 1, 1) - 1 ss = Format(sd, "yyyy") sf = Format(fd, "yyyy") ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 365 Case Else MsgBox "Invalid scale choice " & scaleType Exit Function End Select Select Case edge Case etStart limitofScale = dFirstDayOfStartScale Case etFinish limitofScale = dLastDayOfFinishScale Case etFinishString limitofScale = sf Case etStartString limitofScale = ss Case etEstimatedTicks limitofScale = ticks Case Else Debug.Assert False End Select End Function

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

Private Function limitofScale(scaleType As String, sd As Date, fd As Date, edge As edgeTick) As Variant
Dim dLastDayOfFinishScale As Date, dFirstDayOfStartScale As Variant
Dim ss As String, sf As String, ticks As Single

Select Case Trim(LCase(scaleType))
Case "weeks"
dFirstDayOfStartScale = sd
dLastDayOfFinishScale = fd + 7 - (Weekday(fd) Mod 7)
ss = Format(sd, "dd-mmm-yy")
sf = Format(fd, "dd-mmm-yy")
ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 7

Case "months"
' 1st day of start month
dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd), 1)
' last of finish month
dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 1, 1) - 1
ss = Format(sd, "mmm-yyyy")
sf = Format(fd, "mmm-yyyy")
ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 30

Case "quarters"
dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 3), 1)
dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 3 - ((Month(fd) - 1) Mod 3), 1) - 1
ss = "Q" & CStr(1 + Int((Month(sd) - 1) / 3)) & Format(sd, "yyyy")
sf = "Q" & CStr(1 + Int((Month(fd) - 1) / 3)) & Format(fd, "yyyy")
ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 90

Case "halfyears"
dFirstDayOfStartScale = DateSerial(Year(sd), Month(sd) - ((Month(sd) - 1) Mod 6), 1)
dLastDayOfFinishScale = DateSerial(Year(fd), Month(fd) + 6 - ((Month(fd) - 1) Mod 6), 1) - 1
ss = "H" & CStr(1 + Int((Month(sd) - 1) / 6)) & Format(sd, "yyyy")
sf = "H" & CStr(1 + Int((Month(fd) - 1) / 6)) & Format(fd, "yyyy")
ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 183

Case "years"
dFirstDayOfStartScale = DateSerial(Year(sd), 1, 1)
dLastDayOfFinishScale = DateSerial(Year(fd) + 1, 1, 1) - 1
ss = Format(sd, "yyyy")
sf = Format(fd, "yyyy")
ticks = (dLastDayOfFinishScale - dFirstDayOfStartScale + 1) / 365

Case Else
MsgBox "Invalid scale choice " & scaleType
Exit Function

End Select
Select Case edge
Case etStart
limitofScale = dFirstDayOfStartScale
Case etFinish
limitofScale = dLastDayOfFinishScale
Case etFinishString
limitofScale = sf
Case etStartString
limitofScale = ss
Case etEstimatedTicks
limitofScale = ticks

Case Else
Debug.Assert False
End Select

End Function

Finding the most appropriate scale

In this case we are looking for the ‘best’ scale to use given a start and finish date and a maximum number of axis ticks.

Private Function AutoScale() As String Dim ticks As Single, tickDiff As Single Dim idealticks As Single, sBest As String, s As String Debug.Assert pscType = sctframe idealticks = maxticks * 0.5 tickDiff = maxticks + 1 s = "weeks" ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks) If Abs(idealticks - ticks) < tickDiff Then sBest = s tickDiff = Abs(idealticks - ticks) End If s = "months" ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks) If Abs(idealticks - ticks) < tickDiff Then sBest = s tickDiff = Abs(idealticks - ticks) End If s = "quarters" ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks) If Abs(idealticks - ticks) < tickDiff Then sBest = s tickDiff = Abs(idealticks - ticks) End If s = "halfyears" ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks) If Abs(idealticks - ticks) < tickDiff Then sBest = s tickDiff = Abs(idealticks - ticks) End If s = "years" ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks) If Abs(idealticks - ticks) < tickDiff Then sBest = s tickDiff = Abs(idealticks - ticks) End If If tickDiff > maxticks Then MsgBox "Couldnt find a feasible automatic scale to use for roadmap " & ID End If AutoScale = sBest End Function

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

Private Function AutoScale() As String
Dim ticks As Single, tickDiff As Single
Dim idealticks As Single, sBest As String, s As String
Debug.Assert pscType = sctframe

idealticks = maxticks * 0.5
tickDiff = maxticks + 1

s = "weeks"
ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
If Abs(idealticks - ticks) < tickDiff Then
sBest = s
tickDiff = Abs(idealticks - ticks)
End If

s = "months"
ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
If Abs(idealticks - ticks) < tickDiff Then
sBest = s
tickDiff = Abs(idealticks - ticks)
End If

s = "quarters"
ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
If Abs(idealticks - ticks) < tickDiff Then
sBest = s
tickDiff = Abs(idealticks - ticks)
End If

s = "halfyears"
ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
If Abs(idealticks - ticks) < tickDiff Then
sBest = s
tickDiff = Abs(idealticks - ticks)
End If

s = "years"
ticks = limitofScale(s, Activate, deActivate, etEstimatedTicks)
If Abs(idealticks - ticks) < tickDiff Then
sBest = s
tickDiff = Abs(idealticks - ticks)
End If

If tickDiff > maxticks Then
MsgBox "Couldnt find a feasible automatic scale to use for roadmap " & ID
End If

AutoScale = sBest
End Function

About brucemcp 225 Articles

I am a Google Developer Expert and decided to investigate Google Apps Script in my spare time. The more I investigated the more content I created so this site is extremely rich. Now, in 2019, a lot of things have disappeared or don’t work anymore due to Google having retired some stuff. I am however leaving things as is and where I came across some deprecated stuff, I have indicated it. I decided to write a book about it and to also create videos to teach developers who want to learn Google Apps Script. If you find the material contained in this site useful, you can support me by buying my books and or videos.

Desktop Liberation

The definitive resource for Google Apps Script and Microsoft Office automation

Creating a Date Scale in Excel

Be the first to comment

Leave a Reply Cancel reply