How do you find Leapyear in VBA? - function

What is a good implementation of a IsLeapYear function in VBA?
Edit: I ran the if-then and the DateSerial implementation with iterations wrapped in a timer, and the DateSerial was quicker on the average by 1-2 ms (5 runs of 300 iterations, with 1 average cell worksheet formula also working).

Public Function isLeapYear(Yr As Integer) As Boolean
' returns FALSE if not Leap Year, TRUE if Leap Year
isLeapYear = (Month(DateSerial(Yr, 2, 29)) = 2)
End Function
I originally got this function from Chip Pearson's great Excel site.
Pearson's site

public function isLeapYear (yr as integer) as boolean
isLeapYear = false
if (mod(yr,400)) = 0 then isLeapYear = true
elseif (mod(yr,100)) = 0 then isLeapYear = false
elseif (mod(yr,4)) = 0 then isLeapYear = true
end function
Wikipedia for more...
http://en.wikipedia.org/wiki/Leap_year

If efficiency is a consideration and the expected year is random, then it might be slightly better to do the most frequent case first:
public function isLeapYear (yr as integer) as boolean
if (mod(yr,4)) <> 0 then isLeapYear = false
elseif (mod(yr,400)) = 0 then isLeapYear = true
elseif (mod(yr,100)) = 0 then isLeapYear = false
else isLeapYear = true
end function

As a variation on the Chip Pearson solution, you could also try
Public Function isLeapYear(Yr As Integer) As Boolean
' returns FALSE if not Leap Year, TRUE if Leap Year
isLeapYear = (DAY(DateSerial(Yr, 3, 0)) = 29)
End Function

I found this funny one on CodeToad :
Public Function IsLeapYear(Year As Varient) As Boolean
IsLeapYear = IsDate("29-Feb-" & Year)
End Function
Although I'm pretty sure that the use of IsDate in a function is probably slower than a couple of if, elseifs.

Late answer to address the performance question.
TL/DR: the Math versions are about 5x faster
I see two groups of answers here
Mathematical interpretation of the Leap Year definition
Utilize the Excel Date/Time functions to detect Feb 29 (these fall into two camps: those that build a date as a string, and those that don't)
I ran time tests on all posted answers, an discovered the Math methods are about 5x faster than the Date/Time methods.
I then did some optimization of the methods and came up with (believe it or not Integer is marginally faster than Long in this case, don't know why.)
Function IsLeapYear1(Y As Integer) As Boolean
If Y Mod 4 Then Exit Function
If Y Mod 100 Then
ElseIf Y Mod 400 Then Exit Function
End If
IsLeapYear1 = True
End Function
For comparison, I came up (very little difference to the posted version)
Public Function IsLeapYear2(yr As Integer) As Boolean
IsLeapYear2 = Month(DateSerial(yr, 2, 29)) = 2
End Function
The Date/Time versions that build a date as a string were discounted as they are much slower again.
The test was to get IsLeapYear for years 100..9999, repeated 1000 times
Results
Math version: 640ms
Date/Time version: 3360ms
The test code was
Sub Test()
Dim n As Long, i As Integer, j As Long
Dim d As Long
Dim t1 As Single, t2 As Single
Dim b As Boolean
n = 1000
Debug.Print "============================="
t1 = Timer()
For j = 1 To n
For i = 100 To 9999
b = IsYLeapYear1(i)
Next i, j
t2 = Timer()
Debug.Print 1, (t2 - t1) * 1000
t1 = Timer()
For j = 1 To n
For i = 100 To 9999
b = IsLeapYear2(i)
Next i, j
t2 = Timer()
Debug.Print 2, (t2 - t1) * 1000
End Sub

Public Function ISLeapYear(Y As Integer) AS Boolean
' Uses a 2 or 4 digit year
'To determine whether a year is a leap year, follow these steps:
'1 If the year is evenly divisible by 4, go to step 2. Otherwise, go to step 5.
'2 If the year is evenly divisible by 100, go to step 3. Otherwise, go to step 4.
'3 If the year is evenly divisible by 400, go to step 4. Otherwise, go to step 5.
'4 The year is a leap year (it has 366 days).
'5 The year is not a leap year (it has 365 days).
If Y Mod 4 = 0 Then ' This is Step 1 either goto step 2 else step 5
If Y Mod 100 = 0 Then ' This is Step 2 either goto step 3 else step 4
If Y Mod 400 = 0 Then ' This is Step 3 either goto step 4 else step 5
ISLeapYear = True ' This is Step 4 from step 3
Exit Function
Else: ISLeapYear = False ' This is Step 5 from step 3
Exit Function
End If
Else: ISLeapYear = True ' This is Step 4 from Step 2
Exit Function
End If
Else: ISLeapYear = False ' This is Step 5 from Step 1
End If
End Function

Public Function isLeapYear(Optional intYear As Variant) As Boolean
If IsMissing(intYear) Then
intYear = Year(Date)
End If
If intYear Mod 400 = 0 Then
isLeapYear = True
ElseIf intYear Mod 4 = 0 And intYear Mod 100 <> 0 Then
isLeapYear = True
End If
End Function

I see many great concepts that indicate extra understanding
and usage of date functions that are terrific to learn from...
In terms of code efficiency..
consider the machine code needed for a function to execute
rather than complex date functions
use only fairly fast integer functions
BASIC was built on GOTO
I suspect that something like below is faster
Function IsYLeapYear(Y%) As Boolean
If Y Mod 4 <> 0 Then GoTo NoLY ' get rid of 75% of them
If Y Mod 400 <> 0 And Y Mod 100 = 0 Then GoTo NoLY
IsYLeapYear = True
NoLY:
End Function

Here's another simple option.
Leap_Day_Check = Day(DateValue("01/03/" & Required_Year) - 1)
If Leap_Day_Check = 28 then it is not a leap year, if it is 29 it is.
VBA knows what the date before 1st March is in a year and so will set it to be either 28 or 29 February for us.

Related

What Discrete Optimization family is this?

I am given N lists of M items that will be physically realized (someone actually has to put items (names abbreviated here,) in physical bins.) Then the bins are emptied, if necessary, and re-used, working left-to-right. There is a real cost to putting a different item in a bin than what was in it before. I rearrange the lists to minimize changes, manually. Software can do it faster, and more reliably in an optimum way. The whole thing happens in Excel (then paper, then in a factory.) I wrote some VBA, a brute-force affair, that did really well with some examples. But not all. If I knew the family of optimization that this is, I could code it, even if I just pass something to a DLL. But multiple searches online have not succeeded. I tried several phrasings. It's not a traveling S.., knapsack, etc. It seems similar to the Sequence Alignment problem from Bioinformatics. Someone recognize it? Let's hear it, Operations Research people.
As it turns out, the naive solution just needed tweaking. Look at a cell. Try to find the same letter in the column to it's right. If you find one, swap it with whatever it to the right of that cell now. Work your way down. The ColumnsPer parameter accounts for the real-world use, where each column has an associated list of numbers and the grid columns alternate labels, numbers, labels, ...
Option Explicit
Public Const Row1 As Long = 4
Public Const ColumnsPer As Long = 1 '2, when RM, %
Public Const BinCount As Long = 6
Public Const ColCount As Long = 6
Private Sub reorder_items_max_left_to_right_repeats(wksht As Worksheet, _
col1 As Long, maxBins As Long, maxRecipes As Long, ByVal direction As Integer)
Dim here As Range
Set here = wksht.Cells(Row1, col1)
here.Activate
Dim cond
For cond = 1 To maxRecipes - 1
Do While WithinTheBox(here, col1, direction)
If Not Adjacent(here, ColumnsPer).Value = here.Value Then
Dim there As Range
Set there = Matching_R_ange(here, direction)
If Not there Is Nothing Then swapThem Adjacent(here, ColumnsPer), there
End If
NextItemDown:
Set here = here.Offset(direction, 0)
here.Activate
'Debug.Assert here.Address <> "$AZ$6"
DoEvents
Loop
NextCond:
Select Case direction
Case 1
Set here = Cells(Row1, here.Column + ColumnsPer)
Case -1
Set here = Cells(Row1 + maxBins - 1, here.Column + ColumnsPer)
End Select
here.Activate
Next cond
End Sub
Function Adjacent(fromHereOnLeft As Range, colsRight As Long) As Range
Set Adjacent = fromHereOnLeft.Offset(0, colsRight)
End Function
Function Matching_R_ange(fromHereOnLeft As Range, _
ByVal direction As Integer) As Range
Dim rowStart As Long
rowStart = Row1
Dim colLook As Long
colLook = fromHereOnLeft.Offset(0, ColumnsPer).Column
Dim c As Range
Set c = Cells(rowStart, colLook)
Dim col1 As Long
col1 = c.Column
Do While WithinTheBox(c, col1, direction)
Debug.Print "C " & c.Address
If c.Value = fromHereOnLeft.Value _
And c.Row <> fromHereOnLeft.Row Then
Set Matching_R_ange = c
Exit Function
Else
Set c = c.Offset(1 * direction, 0)
End If
DoEvents
Loop
'returning NOTHING is expected, often
End Function
Function WithinTheBox(ByVal c As Range, ByVal col1 As Long, ByVal direction As Integer)
Select Case direction
Case 1
WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row >= Row1
Case -1
WithinTheBox = c.Row <= Row1 + BinCount - 1 And c.Row > Row1
End Select
WithinTheBox = WithinTheBox And _
c.Column >= col1 And c.Column < col1 + ColCount - 1
End Function
Private Sub swapThem(range10 As Range, range20 As Range)
'Unlike with SUB 'Matching_R_ange', we have to swap the %s as well as the items
'So set temporary range vars to hold %s, to avoid confusion due to referencing items/r_anges
If ColumnsPer = 2 Then
Dim range11 As Range
Set range11 = range10.Offset(0, 1)
Dim range21 As Range
Set range21 = range20.Offset(0, 1)
'sit on them for now
End If
Dim Stak As Object
Set Stak = CreateObject("System.Collections.Stack")
Stak.push (range10.Value) 'A
Stak.push (range20.Value) 'BA
range10.Value = Stak.pop 'A
range20.Value = Stak.pop '_ Stak is empty now, can re-use
If ColumnsPer = 2 Then
Stak.push (range11.Value)
Stak.push (range21.Value)
range11.Value = Stak.pop
range21.Value = Stak.pop
End If
End Sub

SSRS Report Code: Localization converts output to es-MX but the report Language is in en-US so it comes out wrong

I have an SSRS report that uses the following code to calculate some statistics based on parameters selected by the user.
When this runs in Chrome on a machine with en-US localization, the output comes out correct.
When in Chrome in a machine with es-MX localization, the output is off because the decimal becomes a thousands separator (comma) and the thousands separator (comma) becomes a decimal.
Oddly enough, when I run in Edge on the same machine with es-MX, the output is correct.
How do I handle the localization of number formatting within the code embedded in the SSRS report?
Function GetDataSetLabelFromValue
Public function GetDataSetLabelFromValue() as decimal
dim i as integer
dim rBar as decimal
dim processSigma as decimal
dim d2 as decimal
dim restartLow as integer
restartLow = 0
d2 = 1.128
i = 0
rBar = 0.0
IF Report.Parameters!UseRestart.Value =FALSE THEN
restartLow = 0
ELSE
For i =0 to (Report.Parameters!RestartFilter.COUNT() - 1)
IF CBool(Report.Parameters!RestartFilter.Label(i)) = 0 THEN
restartLow = i + 1
END IF
Next i
END IF
IF Report.Parameters!LastBatch.Value = TRUE THEN
for i = restartLow to (Report.Parameters!PSigma.Count() - 2)
rBar = rBar + ABS(Report.Parameters!PSigma.Label(i) - Report.Parameters!PSigma.Label(i+1))
next i
ELSE
for i = restartLow to (Report.Parameters!PSigma.Count() - 3)
rBar = rBar + ABS(Report.Parameters!PSigma.Label(i) - Report.Parameters!PSigma.Label(i+1))
next i
END IF
IF (Report.Parameters!PSigma.Count() - (restartLow))=0 OR (Report.Parameters!PSigma.Count() - (restartLow) - 1)=0 THEN
rBar = 0
ELSE
IF Report.Parameters!LastBatch.Value = TRUE THEN
rBar = rBar / (Report.Parameters!PSigma.Count() - (restartLow))
ELSE
rBar = rBar / (Report.Parameters!PSigma.Count()-restartLow-1)
END IF
END IF
processSigma = rBar / d2
GetDataSetLabelFromValue = processSigma
End Function
Function GetAverageValue
Public function GetAverageValue() as decimal
dim i as integer
dim average as decimal
dim restartLow as integer
restartLow = 0
i = 0
average = 0.0
IF Report.Parameters!UseRestart.VALUE =FALSE THEN
restartLow = 0
ELSE
For i =0 to (Report.Parameters!RestartFilter.COUNT() - 1)
IF CBool(Report.Parameters!RestartFilter.Label(i)) = 0 THEN
restartLow = i + 1
END IF
Next i
END IF
IF Report.Parameters!LastBatch.Value = TRUE THEN
for i = restartLow to (Report.Parameters!PSigma.Count() - 1)
average = average + (CDEC(Report.Parameters!PSigma.Label(i)))
next i
ELSE
for i = restartLow to (Report.Parameters!PSigma.Count() - 2)
average = average + (CDEC(Report.Parameters!PSigma.Label(i)))
next i
END IF
IF (Report.Parameters!PSigma.Count() - (restartLow))=0 OR (Report.Parameters!PSigma.Count() - (restartLow) - 1)=0 THEN
average = 0
ELSE
IF Report.Parameters!LastBatch.Value = TRUE THEN
average = average / (Report.Parameters!PSigma.Count() - (restartLow))
ELSE
average = average / (Report.Parameters!PSigma.Count()-restartLow-1)
END IF
END IF
GetAverageValue = average
End Function

MS Access Textbox Time control

I am wondering if it is possible to control the time entered into MS Access textbox. Eg, only allow user to enter time in half hourly interval (08:30, 10:00, 13:30) as I do not want to end up with weird timing input.. (i.e 13:37, 16:42). Tried to use calculated control but doesn't seem to be working very well. Any suggestions or advice, please?
Calculated control in my textbox
=IIf((Minute([TxtStartTime1]) Mod 30=0),[TxtStartTime1],"00:00")
Below is a screen capture of my form.
Yes, that is possible, but it takes a little - actually that much, that I wrote an article on how-to:
Entering 24-hour time with input mask and full validation in Microsoft Access
It includes all the code needed to set the inputmask, validation, click and keypress events, as well as handling the form error - too much to post here.
Code is also on GitHub: VBA.TimeEntry
To round the time, you may include this function:
Public Function RoundTime( _
ByVal datDate As Date) _
As Date
Const cintMult As Integer = 24 '1 hour round
' Const cintMult As Integer = 48 '30 minute round
' Const cintMult As Integer = 96 '15 minute round
' Const cintMult As Integer = 144 '10 minute round
' Const cintMult As Integer = 288 '5 minute round
RoundTime = CVDate(Int(datDate * cintMult + 0.5) / cintMult)
End Function
You can round entered time for instance in BeforeUpdate event of your control. For rounding I use this VBA function:
Public Function TimeRoundMinutes(dtUnrounded As Date, Optional intRoundTo As Integer = 30, Optional intOption As Integer) As Date
'rounds time of provided date to specified in intRoundTo number of minutes. intOption:
'1 - down
'2 - up
'0 or anything else - to the nearest part
Dim intMins As Integer
If intRoundTo <= 0 Then
intRoundTo = 1
ElseIf intRoundTo > 60 Then
intRoundTo = 60
End If
intMins = Minute(dtUnrounded)
Select Case intOption
Case 1
intMins = Int(intMins / intRoundTo) * intRoundTo
Case 2
intMins = -Int(-intMins / intRoundTo) * intRoundTo
Case Else
intMins = Round(intMins / intRoundTo) * intRoundTo
End Select
If intMins = 60 Then
TimeRoundMinutes = DateAdd("h", 1, Int(dtUnrounded) + TimeSerial(Hour(dtUnrounded), 0, 0))
Else
TimeRoundMinutes = Int(dtUnrounded) + TimeSerial(Hour(dtUnrounded), intMins, 0)
End If
End Function

SSRS distinct lookupset function

I'm using Join(Lookupset) to find unique group values which returns a sequence number. This is my function:
Join(LookupSet(Fields!itemId.Value & Fields!UseByDate.Value & Fields!rackId.Value
, Fields!itemId.Value & Fields!UseByDate.Value & Fields!rackId.Value
, Fields!CustomerSeqNo.Value
, "PickingList"), ",")
The problem is on some items there are multiple transactions. I want to remove the duplicates.
I found a blog http://blogs.msdn.com/b/bobmeyers/archive/2012/06/18/creating-short-lists-using-the-lookupset-function.aspx but could not get SSRS Report Builder to reference Linq assembly. My issue is
How can I just show the unique values?
You don't need Linq, but you do still need custom code (in BIDS go to Report -> Report Properties -> Code)
You can put a RemoveDuplicates function in here, something like this:
Public Shared Function RemoveDuplicates(m_Array As Object()) As String()
System.Array.Sort(m_Array)
Dim k As Integer = 0
For i As Integer = 0 To m_Array.Length - 1
If i > 0 AndAlso m_Array(i).Equals(m_Array(i - 1)) Then
Continue For
End If
m_Array(k) = m_Array(i)
k += 1
Next
Dim unique As [String]() = New [String](k - 1) {}
System.Array.Copy(m_Array, 0, unique, 0, k)
Return unique
End Function
To use it in your Join:
Join(Code.RemoveDuplicates(LookupSet(...)),",")
I agree with #user3697615 that Report Code is best. However, I prefer to build it straight into a string:
public shared function JoinDistinct(
dups as object(),
delimiter as string
) as string
dim result as string = ""
system.array.sort(dups)
for i as integer = 0 to dups.length - 1
if i <> 0 then result += delimiter
if i = 0 orElse dups(i) <> dups(i-1) then result += dups(i)
next i
return result
end function
This way, we eliminate one nested function on the call:
=Code.JoinDistinct(LookupSet(...), ",")
If you're like me, you also want the elements in order based on frequency (descending order).
I created the following VisualBasic code to do so
Public Shared Function RemoveDuplicates(dataset As Object()) As String()
Dim unique As New System.Collections.Generic.List(Of String)
Dim frequency As New System.Collections.Generic.List(Of Integer)
For i As Integer = 0 To dataset.Length - 1
Dim index As Integer = -1
For j As Integer = 0 To unique.Count - 1
If dataset(i).Equals(unique(j)) Then
index = j
Exit For
End If
Next
If index < 0 Then
unique.Add(dataset(i))
frequency.Add(1)
Else
frequency(index) += 1
End If
Next
Dim uniqueArray As [String]() = unique.ToArray()
Array.Sort(frequency.ToArray(), uniqueArray)
Array.Reverse(uniqueArray)
return uniqueArray
End Function
This is based off others' answers where the SSRS expression is the following
Join(Code.RemoveDuplicates(LookupSet(...)),",")
Note: I learned VisualBasic in about an hour to solve this problem, so my algorithm probably isn't the most efficient.
I liked pwilcox's idea, so I wrote this one which filters out null and blank values.
Public Function JoinDistinct(arr As Object(), delimiter As String) As String
System.Array.Sort(arr)
Dim result As String = String.Empty
Dim lastvalue As String = String.Empty
For i As Integer = 0 To arr.Length - 1
If Not arr(i) Is Nothing And arr(i) <> lastvalue And arr(i) <> String.Empty Then
If result = String.Empty Then
result = arr(i)
Else
result = result + delimiter + arr(i)
End If
End If
lastvalue = arr(i)
Next
Return result
End Function
Usage:
=Code.JoinDistinct(LookupSet(...), ",")

Comparison Logic

I have an If statement which I was assuming was comparing each value to each other. However it seems no matter what the values are (e.g. all values contain a count of 4) it goes to the else. Am I missing something in the If statement?
If rst![CountOfProvider] = rst![CountOfDelivery Type] = rst![CountOfBU Creator] = rst![CountOfOrigin] = rst![CountOfSub-Destination] = rst![CountOfDestination Zipcode] = rst![CountOfCity] = rst![CountOfState] = rst![CountOfCost Zone] = rst![CountOfRate] = rst![CountOfMarket Name] Then
chk = False
Else
chk = True
End If
VBA doesn't perform that sequence of comparisons as you seem to expect.
Consider this simpler example from the Immediate window ...
Debug.Print 2 = 2
True
Debug.Print 2 = 2 = 2
False
I'm uncertain how VBA handles those multiple equality comparisons, but suspect it may be testing the first and then comparing the result from that with the next ... sort of like this ...
Debug.Print (2 = 2) = 2
False
The first comparison returns True, which is the integer -1 ...
Debug.Print CInt(2 = 2)
-1
So that means the final comparison would be equivalent to this ...
Debug.Print -1 = 2
And naturally that returns False.
The computationally quickest way is to hard code the comparisons. The more
extensible way is to test via a loop.
HansUp makes a good comment - you should be wary of potential null values and add in a handler to deal with them as desired (e.g. using Nz() in Access or IsNull() in any host environment)
'Method 1
If rst![CountOfProvider] = rst![CountOfDelivery Type] And _
rst![CountOfProvider] = rst![CountOfBU Creator] And _
...etc...Then
chk = False
Else
chk = True
End If
'Method 2
chk = True
For Each ele In Array(rst![CountOfDelivery Type], rst![CountOfBU Creator],...your others...)
If ele <> rst![CountOfProvider] Then
chk = False
Exit For
End If
Next ele