# Calculate Date Differences

Calculating the difference between two dates is rather easy, just subtract one date from the other to return the count of days between the two dates. If you add a number to a date, you will get a new date that is the number of days into the future from the initial date. You can also subtract a number form a date to get a previous date.

Another option is to use the worksheet function DATEDIF that can calculate the difference between two dates in a variety of different intervals, such as the count of years, months, or days between two dates.

The syntax for the DATEDIF-function is: =DATEDIF(Date1;Date2;Interval)
The Norwegian syntax for the function is =DATODIFF(Date1;Date2;Interval)

Where Date1 is the first date, Date2 is the second date and Interval is the interval type to return.
If Date1 is later than Date2, the function will return a #NUM! error.
If Date1 or Date2 is not a valid date, the function will return a #VALUE error.

The Interval argument can be one of these string values:

 Interval: Function Return Value: d Count of days between the two dates md Count of days between the two dates if they were in the same month and year yd Count of days between the two dates if they were in the same year m Count of months between the two dates ym Count of months between the two dates if they were in the same year y Count of years between the two dates

If the Interval argument is not one of the items listed in above, the function will return a #NUM error.

To calculate the number of years, months, and days between two dates, you can use a formula like this, where cell A1 contains the start date and cell B1 contains the end date:
=DATEDIF(A1;B1;”y”)&” years “&DATEDIF(A1;B1;”ym”)&” months “&DATEDIF(A1;B1;”md”) &” days”

This formula will return a string result like: 10 years 6 months 21 days

The DATEDIF function has not been documented much in the Excel help files by Microsoft, probably because the function was only implemented to make Excel compatible with their initial main spreadsheet rival Lotus 1-2-3.
The DATEDIF function was supposedly documented in the help file for Excel 2000. In more recent days the function was documented in the Excel for Mac online function reference.

The curious thing is that the DATEDIF function is also used and documented in Windows SharePoint 2003, 2007 and 2010.

### Calculating Date Differences in VBA:

In VBA you can calculate date differences use a similar function, the DateDiff-function:

```Sub ExamplesUsingDateDiffFunction()
Dim lngResult As Long, lngStartDate As Long, lngEndDate As Long
lngStartDate = DateSerial(2000, 1, 1)
lngEndDate = Date ' today
lngResult = DateDiff("yyyy", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " years"
lngResult = DateDiff("q", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " quarters"
lngResult = DateDiff("m", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " months"
lngResult = DateDiff("w", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " weeks (days)"
lngResult = DateDiff("ww", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " weeks (calendar)"
lngResult = DateDiff("d", lngStartDate, lngEndDate, vbMonday, vbFirstFourDays)
Debug.Print lngResult & " days" ' y returns the same
End Sub
```

# Delay Code Execution And Get Elapsed Time

If you need to delay something or want to get the elapsed time and don’t need an accuracy better than 1 second, you can use the information in the example macro below:

```Sub TimerExample1()
' accuracy in seconds
Dim s As Double, e As Double, i As Long
Dim dblElapsedTime As Double
s = Now ' start date and time
For i = 1 To 25
ActiveSheet.Calculate ' do something
Next i
e = Now ' end date and time
dblElapsedTime = e - s ' in seconds
MsgBox "Elapsed Time: " & Format(dblElapsedTime, "hh:mm:ss") & _
" (" & Format(dblElapsedTime * 86400, "0.00") & " seconds)", vbInformation

s = Now ' start date and time
Application.Wait Now + TimeValue("00:00:03") ' pause code execution for 3 seconds
e = Now ' end date and time
dblElapsedTime = e - s ' in seconds
MsgBox "You waited for " & Format(dblElapsedTime, "hh:mm:ss") & _
" (" & Format(dblElapsedTime * 86400, "0.00") & " seconds)", vbInformation
End Sub
```

If you need to delay something or want to get the elapsed time and you need an accuracy that is better than 1 second, you can use the functions and procedures below:

```Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' pause code execution
Declare Function GetTickCount Lib "kernel32" () As Long ' milliseconds elapsed since Windows was started (accuracy 10-16 ms)
' Declare Function GetTickCount64 Lib "kernel32" () As Long ' milliseconds elapsed since Windows was started (accuracy 10-16 ms)

Function GetTickCountDifference(lngStart As Long, lngEnd As Long) As Long
' assumes input times in milliseconds, returns the difference in milliseconds
If lngEnd < lngStart Then
' assumes that the tick count has been reset
' this happens when the tick count is greater than 2^32, approximately every 49.71 days
lngEnd = lngEnd + 2 ^ 32
End If
GetTickCountDifference = lngEnd - lngStart
End Function

Sub TimerExample2()
' accuracy in milliseconds
Dim s As Long, e As Long, i As Long
Dim lngElapsedTime As Long
s = GetTickCount ' start time
For i = 1 To 25
ActiveSheet.Calculate ' do something
Next i
e = GetTickCount ' end time
lngElapsedTime = GetTickCountDifference(s, e) ' in milliseconds
MsgBox "Elapsed Time: " & Format(lngElapsedTime / 1000 / 86400, "hh:mm:ss") & _
" (" & Format(lngElapsedTime / 1000, "0.00") & " seconds)", vbInformation

s = GetTickCount ' start time
Sleep 2750 ' pause code execution for 2.75 seconds
e = GetTickCount ' end time
lngElapsedTime = GetTickCountDifference(s, e) ' in milliseconds
MsgBox "You waited for " & Format(lngElapsedTime / 1000 / 86400, "hh:mm:ss") & _
" (" & Format(lngElapsedTime / 1000, "0.00") & " seconds)", vbInformation
End Sub
```

# Aligning strings within a fixed width

With the functions below you can align a string (left, center or right) within a fixed width, this might be useful when you e.g. create reports with fix-width column formats.

```Function AlignLeft(varItem As Variant, intWidth As Integer) As String
Dim strResult As String, i As Integer
strResult = CStr(varItem)
i = intWidth - Len(strResult)
If i > 0 Then
strResult = strResult & Space(i)
End If
If Len(strResult) > intWidth Then
strResult = Left\$(strResult, intWidth)
End If
AlignLeft = strResult
End Function

Function AlignCenter(varItem As Variant, intWidth As Integer) As String
Dim strResult As String, i As Integer
strResult = CStr(varItem)
i = intWidth \ 2 - Len(strResult) \ 2
If i > 0 Then
strResult = Space(i) & strResult
End If
If Len(strResult) > intWidth Then
strResult = Left\$(strResult, intWidth)
End If
AlignCenter = strResult
End Function

Function AlignRight(varItem As Variant, intWidth As Integer) As String
Dim strResult As String, i As Integer
strResult = CStr(varItem)
i = intWidth - Len(strResult)
If i > 0 Then
strResult = Space(i) & strResult
End If
AlignRight = strResult
End Function
```

# Retrieving formula results

If you need to get the result from a formula in a cell, you would normally do something like this:

`dblValue = Range("A1").Value`

If you need to calculate parts of a formula or math expression then you can do something like this:

```' assume that cell A1 contains this formula:
' =(A2+A3)/(A4+A5)
strFormula = Range("A1").Formula
varItems = Split(strFormula, "/")
dblValueFirst = Application.Evaluate(varItems(0))
dblValueSecond = Application.Evaluate(varItems(1))
```

The evaluating expression can contain both cell references, functions and regular math expressions, all of the examples below will return a value:

```dblValue = Application.Evaluate("(A4+A5)")
dblValue = Application.Evaluate("=AVERAGE(A1:A9)")
dblValue = Application.Evaluate("AVERAGE(A1:A9)")
dblValue = Application.Evaluate("=2+3*4")
dblValue = Application.Evaluate("2+3*4")
```

# Calculate workdays

With the custom functions below you can calculate the count of workdays between two dates. Workdays includes normal weekdays except Saturdays and Sundays or holidays e.g. like Easter).

The functions can be used like this in a worksheet cell:

```=CountWorkDays(A1,B1)
=DateIsHoliday(A1)
```

The date input cells must contain valid Excel dates, or formulas/functions that return dates, e.g. =TODAY().

```Function CountWorkDays(StartDate As Long, EndDate As Long) As Long
' returns the workday count between two dates
Dim d As Long, dCount As Long
dCount = 0
If StartDate < 1 Or EndDate < 1 Then Exit Function

If StartDate <= EndDate Then
For d = StartDate To EndDate
If Not DateIsHoliday(d) Then
dCount = dCount + 1
End If
Next d
Else
For d = StartDate To EndDate Step -1
If Not DateIsHoliday(d) Then
dCount = dCount + 1
End If
Next d
End If
CountWorkDays = dCount
End Function

Function AddWorkDays(StartDate As Long, Offset As Long) As Long
' returns a date Offset days from StartDate
Dim d As Long, dCount As Long
If StartDate < 1 Then Exit Function
d = StartDate
If Abs(Offset) > 0 Then
dCount = 0
If Offset > 0 Then
Do
If Not DateIsHoliday(d) Then
dCount = dCount + 1
End If
d = d + 1
Loop Until dCount = Offset
d = d - 1
Else
Do
If Not DateIsHoliday(d) Then
dCount = dCount - 1
End If
d = d - 1
Loop Until dCount = Offset
d = d + 1
End If
End If
End Function

Function DateIsHoliday(InputDate As Long) As Boolean
' returns True if InputDate is a Saturday/Sunday or a holiday (Norwegian)
Dim d As Integer, intYear As Integer, lngEasterSunday As Long, OK As Boolean
OK = False
If InputDate > 0 Then
If Weekday(InputDate, vbMonday) >= 6 Then ' Saturday or Sunday
OK = True
End If
If Not OK Then ' check if InputDate is a holiday
intYear = Year(InputDate)
d = (((255 - 11 * (intYear Mod 19)) - 21) Mod 30) + 21
lngEasterSunday = DateSerial(intYear, 3, 1) + d + (d > 48) + 6 - ((intYear + intYear \ 4 + d + (d > 48) + 1) Mod 7)
OK = True
Select Case InputDate
Case CDate("1.1." & intYear) ' 1. January
'Case lngEasterSunday - 4 ' Wednesday before Easter
Case lngEasterSunday - 3 ' Thursday before Easter
Case lngEasterSunday - 2 ' Friday before Easter
Case lngEasterSunday ' Easter Sunday
Case lngEasterSunday + 1 ' Monday after Easter
Case CDate("1.5." & intYear) ' 1. May
Case CDate("17.5." & intYear) ' 17. May
Case lngEasterSunday + 39 ' Ascension Day
'Case lngEasterSunday + 48 ' Pentecost
Case lngEasterSunday + 49 ' Pentecost
Case lngEasterSunday + 50 ' Pentecost
'Case CDate("24.12." & intYear) ' Christmas
Case CDate("25.12." & intYear) ' Christmas
Case CDate("26.12." & intYear) ' Christmas
'Case CDate("31.12." & intYear) ' New Years Eve
Case Else
OK = False
End Select
End If
End If
DateIsHoliday = OK
End Function
```

# Return unique items from a cell range

The macro below will return a collection with the unique items from a cell range.
The collection can optionally be populated with separate keys and values.

```Function GetUniqueItems(KeyRange As Range, Optional ItemRange As Range) As Collection
Dim r As Long, c As Long, varItem As Variant, strKey As String
If Not KeyRange Is Nothing Then
Set GetUniqueItems = New Collection
With KeyRange
For c = 1 To .Columns.Count
For r = 1 To .Rows.Count
strKey = vbNullString
varItem = vbNullString
On Error Resume Next
strKey = Trim(CStr(.Cells(r, c).Value))
If Not ItemRange Is Nothing Then
varItem = ItemRange.Cells(r, c).Value
Else
varItem = .Cells(r, c).Value
End If
If Len(strKey) > 0 Then
End If
On Error GoTo 0
Next r
DoEvents
Next c
End With
If GetUniqueItems.Count = 0 Then
Set GetUniqueItems = Nothing
End If
End If
End Function

Sub TestCopyUniqueItems()
Dim coll As Collection, i As Long
Set coll = GetUniqueItems(Range("A1:A100"))
If coll Is Nothing Then Exit Sub

Range("C1:C100").Clear
For i = 1 To coll.Count
Range("C1").Offset(i - 1, 0).Formula = coll(i)
Next i
End Sub
```

The macro below will use the built in filter functionality in Excel to return all the unique items from a range to another range:

```Sub FindUniqueValues(SourceRange As Range, TargetCell As Range)
CopyToRange:=TargetCell,  Unique:=True
End Sub
```

You can use the macro like this to copy all the unique items from A1:A100 to cell C1 and below:

```Sub TestFindUniqueValues()
FindUniqueValues Range("A1:A100"), Range("C1")
End Sub
```

# Convert Numbers To Text

Display any number as text, 9999 = ninethousand ninehundredandninetynine.
English and Norwegian text, other languages needs some editing.
Source code for Indonesian language (Bahasa Indonesia) is also included, translated by Billy S. C. Ticoalu.

Updated: 2006-05-07 & 2012-04-11 Requires: XL5 File size: 40 kB

# Open and close the CD/DVD tray

With the macros below you are able to open and close the default CD/DVD tray.

```Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long)

Sub OpenDefaultDiscTray()
mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub

Sub CloseDefaultDiscTray()
mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub```

You can use the macro below to open a specific CD/DVD tray if you know the drive letter.
You will need a third party tool if you want to close the tray by code.

```Sub OpenDiscTray(strDriveLetter As String)
' this will open the CD/DVD tray for the given drive letter
' e.g.: OpenDiscTray "F"
Dim Shell As Object, MyComputer As Object
Set Shell = CreateObject("Shell.Application")
Set MyComputer = Shell.Namespace(17)
On Error Resume Next
MyComputer.ParseName(strDriveLetter & ":").InvokeVerb ("e&ject")
On Error GoTo 0
Set MyComputer = Nothing
Set Shell = Nothing
End Sub```

You can use the macro below to determine if a drive is ready, e.g. when a disc is present in a CD/DVD drive.

```Function DriveIsReady(strDriveLetter As String) As Boolean
' returns True if a drive is ready, e.g. a disc is present in a CD/DVD drive
Dim fso As Scripting.FileSystemObject, drv As Scripting.Drive
Dim Shell As Object, MyComputer As Object
Set fso = New FileSystemObject
On Error Resume Next
Set drv = fso.GetDrive(strDriveLetter)
On Error GoTo 0
If Not drv Is Nothing Then
Set drv = Nothing
End If
Set fso = Nothing
End Function```

Here is an example macro that uses the last two example macros:

```Sub TestDiscTrays()
Dim i As Integer
OpenDiscTray "G"
i = MsgBox("Click OK when you have inserted a new disc.", vbOKCancel)
If i = vbCancel Then Exit Sub ' user aborted

MsgBox "Disc not inserted, aborting...", vbExclamation
Exit Sub
End If

'FileCopy "G:somefile.txt", "C:"

End Sub```

# Split a string and return any individual part

This function splits a character separated string into its indivual parts and returns any given part.
The function can also be used as a worksheet function.
The function will only work in Excel 2000 or later.

```Function GetStringPart(strInput As String, strDelimiter As String, _
intPart As Integer) As String
Dim varStrings As Variant
varStrings = Split(strInput, strDelimiter, -1, vbBinaryCompare)
On Error Resume Next
GetStringPart = Trim(varStrings(intPart - 1))
On Error GoTo 0
End Function
```

Example:
If cell A1 contains this string:
Doe, John, Streetname 15, 12345 Town, Statename

=GetStringPart(A1,”,”,1) will return “Doe”
=GetStringPart(A1,”,”,4) will return “12345 Town”
=GetStringPart(A1,”,”,9) will return “” (a blank/empty string)

In VBA the function can be used like this:
strFirstName = GetStringPart(Range(“A1″).Value, “,”, 2)

# Get a custom color from the user

The function below can be used to let the user pick or select a custom color. It uses the Excel applications own built in dialog for selecting colors. Unfortunately this built in dialog does not return a value for the color selected by the user. If the user selects a color in the dialog, it will update the active workbooks color palette with the selected color. Because of this limitation, the function below will not work there is not an active workbook. The function can also be used in a UserForm / dialog.

```Function GetUserSelectedColor(Optional lngInitialColor As Long = 16777215) As Long
Dim lngResult As Long, lngO As Long, intR As Integer, intG As Integer, intB As Integer
lngResult = xlNone ' default function result
' this function requires that a workbook is active
If Not ActiveWorkbook Is Nothing Then
' save the original first palette color so it is possible to restore it
lngO = ActiveWorkbook.Colors(1)
' get the RGB values of lngInitialColor
intR = lngInitialColor And 255
intG = lngInitialColor \ 256 And 255
intB = lngInitialColor \ 256 ^ 2 And 255
If Application.Dialogs(xlDialogEditColor).Show(1, intR, intG, intB) = True Then
' the user selected a color and the first color in the palette was updated
lngResult = ActiveWorkbook.Colors(1)
' reset the changed palette color to the original color
ActiveWorkbook.Colors(1) = lngO
End If
End If
GetUserSelectedColor = lngResult
End Function
```

Here are a few examples:

```Sub ChangeCellColor()
Dim lngColor As Long
' lngColor = GetUserSelectedColor() ' no default color
lngColor = GetUserSelectedColor(ActiveCell.Interior.Color)
If lngColor <> xlNone Then
ActiveCell.Interior.Color = lngColor
End If
End Sub

Private Sub Label1_Click()
Dim c As Long
c = GetUserSelectedColor(Me.Label1.BackColor)
If c <> xlNone Then
Me.Label1.BackColor = c
End If
End Sub
```