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

Create Page Breaks in Excel

Often you might have a large table of data that needs to be grouped and printed on separate pages based on the value in a column. This procedure asks for the column containing the group by value, clears any previous page breaks, resets the page breaks and goes to print preview mode.

Sub PageBreaks()
' Place page breaks on a worksheet based on the value in
' the column specified by the user. Sets the first row
' as headers to repeat on each page and activates the
' print preview mode.

Dim strColumn As String ' Column containing the break value
Dim lRows As Long ' Rows in the used range
Dim lTitleRow As Long ' Row containing the column headers
Dim vaValue1 As Variant ' 1st value to compare
Dim vaValue2 As Variant ' 2nd value to compare
Dim l As Long ' loop counter

lRows = ActiveSheet.UsedRange.Rows.Count

strColumn = InputBox("Enter the column containing the page break information.")
' Exit the sub if the user presses cancel.
If strColumn = "" Then
Exit Sub
End If

ActiveSheet.ResetAllPageBreaks
lTitleRow = 1

For l = 2 To lRows
Cells(l + 1, strColumn).Activate
vaValue1 = Cells(l, strColumn).Value
vaValue2 = Cells(l + 1, strColumn).Value
If vaValue2 <> vaValue1 Then
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
End If
Next l

ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
ActiveSheet.PrintPreview

Range("A1").Activate

End Sub