LastDayofTheWeek Function

Returns a Variant (Date) containing the date of the last day of the week either before or after the EvalDate.

Syntax

LastDayOfWeek(EvalDate,LastDay, ReturnType)

EvalDate is the date to evaluated.

LastDay is a number between 1 and 7 representing the last day for the week If omitted the value is set to 1 (Sunday)

1 = Sunday
2 = Tuesday
3 = Wednesday
4 = Thursday
5 = Friday
6 = Saturday
7 = Sunday

ReturnType is either 0 or 1. If omitted 0 is assumed. 0 returns the date of the last day of the week after the EvalDate, 1 returns the date of the last day of the week prior to the EvalDate.

---

Option Explicit

---

Public Function LastDayOfWeek(EvalDate As Date, Optional LastDay As Integer, Optional ReturnType As Integer) As Date
' Determines the date of the last day of the week based on the user's input
' EvalDate is the date to be evaluated
' LastDay is the weekday number of the last day of the week starting with
' 1 = Sunday, 2 = Monday, etc...
' ReturnType is either 0 (zero) or 1. Zero returns date of the last day of the week after the EvalDate
' 1 returns the date of the last day of the week prior to the EvalDate. If omitted zero is assumed.

Dim intEvalWeekday As Integer ' The weekday of the date to be evaluated
Dim intDifference As Integer

intEvalWeekday = Weekday(EvalDate, vbSunday)

' If the LastDay agument was omitted the value is set as 1 (Sunday).
' If the user enters a number that is not between 1 and 7 an error message
' is displayed.
If LastDay = 0 Then
LastDay = 1
ElseIf LastDay > 7 Or LastDay <>
MsgBox "Enter a number between 1 and 7 representing the day that is the last day of the week." _
& vbCr & vbCr & _
"1 = Sunday" & vbCr & "2 = Monday" & vbCr & "3 = Tuesday" & vbCr & _
"4 = Wednesday" & vbCr & "5 = Thursday" & vbCr &amp; "6 = Friday" & vbCr & _
"7 = Saturday", vbCritical
LastDayOfWeek = "Error" ' This forces an error. Otherwise the formula will display "01/01/00"
Exit Function
End If

intDifference = LastDay - intEvalWeekday

' Determine output value of the function
If ReturnType = 0 Then ' Return the date for the last day of the week that follows the EvalDate
Select Case intDifference
Case 0
LastDayOfWeek = EvalDate
Case Is > 0
LastDayOfWeek = EvalDate + (LastDay - intEvalWeekday)
Case Is <>
LastDayOfWeek = EvalDate + (7 + LastDay - intEvalWeekday)
End Select
ElseIf ReturnType = 1 Then ' Return the date for the last day of the week that precedes the EvalDate
Select Case intDifference
Case 0
LastDayOfWeek = EvalDate
Case Is > 0
LastDayOfWeek = EvalDate - ((7 + intEvalWeekday) - LastDay)
Case Is <>
LastDayOfWeek = EvalDate + (LastDay - intEvalWeekday)
End Select
End If
End Function

Shading Unlocked Cells

The below subs shade and unshade the unlocked cells in the active sheet. The third sub clears all the unlocked cells. When I create an application I protect the sheet and shade the cells that the users can input data into.

This is also an easy way to check what cells are unlocked.

---

Sub UnShade()
' Set the ColorIndex for all the unlocked cells on the
' ActiveSheet to 0.
ActiveSheet.Unprotect
Set rngLast = Range("A1").SpecialCells(xlCellTypeLastCell)
llastColumn = rngLast.Column
lLastRow = rngLast.Row
Set rngUsed = Range("A1", rngLast)
r = 1
c = 1
Do Until r = lLastRow + 1
Do Until c = llastColumn + 1
If Cells(r, c).Locked = False Then
Cells(r, c).Interior.ColorIndex = 0
End If
c = c + 1
Loop
c = 1
r = r + 1
Loop
ActiveSheet.Protect
End Sub

---

Sub Shade()
' Set the ColorIndex for all the unlocked cells on the
' ActiveSheet to 4.
ActiveSheet.Unprotect
Set rngLast = Range("A1").SpecialCells(xlCellTypeLastCell)
llastColumn = rngLast.Column
lLastRow = rngLast.Row
Set rngUsed = Range("A1", rngLast)
r = 1
c = 1
Do Until r = lLastRow + 1
Do Until c = llastColumn + 1
If Cells(r, c).Locked = False Then
Cells(r, c).Interior.ColorIndex = 4
End If
c = c + 1
Loop
c = 1
r = r + 1
Loop
ActiveSheet.Protect
End Sub

---

Sub ClearUnlockedCells()
' Clear contents of all unlocked cells in the active
' sheet.
ActiveSheet.Unprotect
Set rngLast = Range("A1").SpecialCells(xlCellTypeLastCell)
llastColumn = rngLast.Column
lLastRow = rngLast.Row
Set rngUsed = Range("A1", rngLast)
r = 1
c = 1
Do Until r = lLastRow + 1
Do Until c = llastColumn + 1
If Cells(r, c).Locked = False Then
Cells(r, c).ClearContents
End If
c = c + 1
Loop
c = 1
r = r + 1
Loop
ActiveSheet.Protect
End Sub

Update All Pivot Tables in the Active Workbook

This sub updates all the pivot tables in the active workbook.

Sub UpdatePivotTables()
' Updates all the pivot tables in the ActiveWorkbook.
Application.ScreenUpdating = False
For Each pc In ActiveWorkbook.PivotCaches
pc.Refresh
Next
Application.ScreenUpdating = True
End Sub