VBA pop-up box depending on time of day - ranges to be defined

[dancing-shadow]

I have managed to find a similar macro on the net that I have customised for my own use, however there are certain aspects that are beyond my capability of amending.



This is the code so far:

Option Explicit

Sub ReportsDue()
    Dim counter As Long
    Dim iUpdates As Integer
    Dim rng As Range
 
    
        Application.ScreenUpdating = False
        
'Macro to run if the time of now matches any of the times in column D
        
        Sheets("Projects").Activate
        
        iUpdates = WorksheetFunction.CountIf(Columns(4), TimeValue("08:00:00 AM"))

'TimeValue needs to match the current time of Now(), not specifically 08:00


            If iUpdates = 0 Then Sheets("Projects").Activate
            
            For counter = 1 To 59
                Set rng = Range("D" & counter)
                    If Not IsEmpty(rng) Then
'Need to add in and(Range("BS:BS"),<=Date,(Range("BX:BX"),>=Date))
                    
                        MsgBox _
                            iUpdates & " Reports are due out:" & vbCrLf & _
                            vbCrLf & _
                            "Project " & rng.Offset(, -3).Value & vbCrLf & _
                            vbCrLf & _
                            "Owner: " & rng.Offset(, -2).Value & vbCrLf & _
                            vbCrLf & _
                            "Due by: " & rng.Value & vbCrLf & _
                            vbCrLf
'Last value is to be formatted as a time - currently shows decimal value
                        
                    End If
            Next counter
        Application.ScreenUpdating = True
        
End Sub

The message box is on a worksheet I have open every day, all day, and is designed to alert me to certain reports that need sending out by certain times.

On my worksheet, column D has the time that the report is due out by. Col A has the Project name, and column B has the owner of that project.
Col BS and BX have the start and finish dates for the project respectively.

I want the message box to only alert me to any project where todays date is between the dates in BS and BX, Column D is not blank, and of Now() matches the time in column D.

So through the day, I might get a message box at 08:00 to alert of project A, B and C, and a 2nd message box at 09:00 to alert of projects D, E and F.

Although I have this workbook open all day, I'm not specifically looking at it, so conditional formatting would get missed - hence I need a box that I have to manually click off.

Any help would be greatly appreciated as always

[Leith Ross]

Hello dancing-shadow,

Can you post a copy of the workbook? If it contains any sensitive information, please redact it before you post the workbook.

[dancing-shadow]

Book1.xlsm

hth

[Leith Ross]

Hello dancing-shadow,

Thanks for the workbook. Would there be an occasion where you would have more than one report due at the same time of day?

[Leith Ross]

Hello dancing-shadow,

The attached workbook will automatically check the reports once the workbook is opened. Checks are made every minute. Any report falling within the dates and matching the current time are listed in a dialog box.

Public RemindersOn As Boolean

Sub ReportReminder()

    Dim BegDate As Date
    Dim Cell As Range
    Dim EndDate As Date
    Dim EndRow As Long
    Dim Msg As String
    Dim Owner As String
    Dim Project As String
    Dim Rng As Range
    Dim Row As Long
    Dim Wks As Worksheet
    
        Set Wks = Sheet1
        
        Set Rng = Wks.Range("A4:D4")
        EndRow = Wks.Cells(Rows.Count, Rng.Column).End(xlUp).Row
        
        If EndRow < Rng.Row Then Exit Sub
        
        Set Rng = Rng.Resize(RowSize:=EndRow - Rng.Row + 1)
        
            For Each Cell In Rng.Columns("D:D").Cells
                If Not IsEmpty(Cell) Then
                    If Cell = TimeSerial(Hour(Now), Minute(Now), 0) Then
                        Row = Cell.Row
                        If Date >= Wks.Cells(Row, "BS") And Date <= Wks.Cells(Row, "BT") Then
                            If Msg = "" Then Msg = "The following Projects are Due..." & vbCrLf & vbCrLf
                            Row = Cell.Row
                            Msg = Msg & "Project: " & Wks.Cells(Row, "A") & vbCrLf
                            Msg = Msg & "Owner: " & Wks.Cells(Row, "B") & vbCrLf
                            Msg = Msg & vbCrLf
                        End If
                    End If
                End If
            Next Cell
            
        If Msg <> "" Then MsgBox Msg, vbOKOnly, "Reminder " & Format(Now(), "h:mm AM/PM")
        Call StartReminders
        
End Sub

Sub StartReminders()
    If RemindersOn = True Then Application.OnTime Now() + TimeSerial(0, 1, 0), "ReportReminder", , True
End Sub

Sub StopReminders()
    RemindersOn = False
End Sub

[dancing-shadow]

Hi - thank you for your time and effort on this! It's most appreciated

For your earlier question, yes there will be instances where there could be more than one report due out at the same time.

I've tried copying your macro into my workbook (both the one for 'ThisWorkbook' and for 'Module1'), but in my sheet it is not working.


On the sheet you have attached it is intermittantly working - sometimes it opens and works, other times keeps locking/unlocking itself, and errors with
'Cannot run the macro "C:\Users.....Temporary Internet Files\Low\Content\IE5\85JHMU00\Report%20Reminder%20ver201[1].xlsm'!ReportReminder'. The macro may not be available in this workbook or all macros may be disabled.'

Also every time it locks/unlocks/errors it also opens a duplicate of the sheet. Currently I have 5 open... !!

I've downloaded it and saved it into my documents, rather than opening straight from the website, but not sure what's causing it to do this. Also not sure why I got it to work on yours before I closed and reopened it, and couldn't replicate it on mine (other than I had to change column BS to BX - my mistake on my dummy file...

[dancing-shadow]

I've had another test this morning, and I can now get your sheet opened and working (without creating duplicates!). However I'm still having issues copying it onto my own file.

Is it an issue with this part of code?

Set Wks = Sheet1

The tab I'm using it for is call 'Projects' and is the 4th tab on my workbook, so does 'Sheet1' need to change?

[Leith Ross]

Hello dancing-shadow,

Good catch on that. You can do this one of two ways...

    Set Wks = Worksheets("Projects")

' OR

    Set Wks = Sheet4

The first method uses the name you have assigned to the worksheet (tab). The second is the code name assigned by Excel. The code name can not be changed. It will always be the same regardless of what you decide to name the tab.