'This sub must be installed in the code pane for the calendar worksheet. It will not work at all if installed anywhere else.
Private Sub Worksheet_Activate()
Dim ws As Worksheet, wsCalendar As Worksheet
Dim rg As Range, rgDest As Range
Dim n As Long
'Application.ScreenUpdating = False
Set wsCalendar = Worksheets("Calendar")
wsCalendar.Range("a2", "f10000").Clear
'wsCalendar.Rows(2).Resize(wsCalendar.Rows.Count - 1).ClearContents
'wsCalendar.Rows.ClearContents
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "Calendar", "Home", "Working Space" 'Ignore these worksheets
Case Else
With ws
'ws.Activate
Set rg = .Range("B4").Resize(.UsedRange.Rows.Count, 5) 'Look at columns B:F, starting in row 4
If (Not Intersect(rg, .UsedRange) Is Nothing) And (rg.Cells(2, 1) <> "") Then
'rg.AutoFilter Field:=2, Criteria1:="<=" & (Date + 5), Operator:=xlAnd, Criteria2:=">=" & (Date - 5)
'must be US date format
today = Format(Date, "mm-dd-yyyy")
rg.AutoFilter Field:=2, Criteria1:=">=" & today ', Operator:=xlAnd, Criteria2:=">=" & plus5days
Set rgDest = wsCalendar.Cells(wsCalendar.UsedRange.Rows.Count + wsCalendar.UsedRange.Row, 2)
.AutoFilter.Range.Copy rgDest
n = wsCalendar.UsedRange.Rows.Count + wsCalendar.UsedRange.Row - rgDest.Row
rgDest.Offset(0, -1).Resize(n, 1).Value = ws.Name
rgDest.Rows(1).EntireRow.Delete
.Range("B4").AutoFilter
End If
End With
End Select
Next
Application.ScreenUpdating = True
End Sub
|
