locked
Outlook Email reminders based on Excel schedule RRS feed

  • Question

  • Hello,

    What I've been attempting to do recently is build a somewhat simple macro for sending email reminders based on an Excel file contents. To simplify things, the source Excel file looks roughly like this:

    Someheaders

    1 | Blahblahtaskdescription| DATE | TIME

    2 | Blahblahtaskdescription| DATE | TIME

    3 ...

    And the schedule's time span is several days - my aim was to send a "summary" of tasks per given day on 6:00 AM Mon-Fri and then afterwards, exactly 1H before a given tasks deadline, a further reminder with just this particular task's details (or several tasks' if they happen to share the exact same deadline).

    Below is the code I started to write, admittedly there are some areas I have difficulties with. For instance I am not sure how .DeferredDeliveryTime can obtain data from specific reference cells, and how can I subtract 1H from such a reference. Also I am baffled to an extent when trying to "slice" the schedule so that each Email includes always the same headers + only the required tasks (for the daily "summary" or for the 1H-TO-DEADLINE reminder).

    Any advise on how to tackle this would be greatly appreciated!

    Sub MECDailyMail()
    
        Dim rng As Range
        Dim OutApp As Object
        Dim OutMail As Object
    
        Set rng = Nothing
        On Error Resume Next
    
        Set rng = Selection.SpecialCells(xlCellTypeVisible)
    
        On Error GoTo 0
    
        If rng Is Nothing Then
            MsgBox "Error:" & _
                   vbNewLine & "The selection is not a range or the sheet is protected.", vbOKOnly
            Exit Sub
        End If
    
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        On Error Resume Next
        
        SigString = Environ("appdata") & _
                    "\Microsoft\Signatures\Mysig.htm"
                    
        With OutMail
            .To = "mail@examp.le"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Importance = olImportanceHigh
            .DeferredDeliveryTime = Range("K2") & Range("J2" - 1) 'here I am trying to subtract 1H from the reference cells time
            .HTMLBody = RangetoHTML(rng)
            .Send
        End With
        On Error GoTo 0
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub

    I understand full well that the above might not be much to work on, so I'd me more than happy to provide further info as needed - just let me know :).

    EDIT: Here is the sample file https://1drv.ms/x/s!AtsoeYc3XMyLpxH9Ht12zpTIWkOs

    Best regards,

    Miłosz




    • Edited by MiłoszNiedziela Tuesday, September 20, 2016 7:45 AM adding sample file link from 1drv
    Monday, September 19, 2016 2:12 PM

Answers

  • Actually I overlooked one point.

    Rng.Specialcells(xlcelltypevisible).rows.count

    I always wrongly expect the above is expected to give count of filtered rows. But it only gives count of 1st area. Replaced that part. There were two other problem which sorted out.

    I tested on a small sample that is why I could not find the bugs.Now have run on all table and no issue like above.

    Run it on a different schedule and let me know. Hope some small change can make the code final.

    But pls go through each line. It will help you in tweaking and updating for future. The code may be lengthy but basically it is only Filtering, Copying the filtered data, pasting if more than one row,removing duplicates.

    You can ask if any line is not clear.

    Sub CreateMailScheduleTwentySecondSept()
        Dim outapp As Object
        
        Dim rAll As Range
        Dim rDate As Range
        Dim rDLine As Range
        Dim rRes As Range
            
        
        Dim dC As Date
        Dim rA As Range
        Dim rD As Range
        Dim rAU As Range
        Dim rDU As Range
        Dim rLO As Range
        Dim rLT As Range
        Dim rT As Range
        
        
        Dim lR As Long
        Dim lDateC As Long
        Dim lDLineC As Long
        Dim lResC As Long
        
        Dim wb As Workbook
        
        
        'Getting user input
        
        Err.Clear
        On Error Resume Next
            Set rAll = Application.InputBox(prompt:="Pls select the Table", Type:=8)
            Set rRes = Application.InputBox(prompt:="Pls select the Res Column.Any one cell", Type:=8)
            Set rDate = Application.InputBox(prompt:="Pls select the Date Column.Any one cell", Type:=8)
            Set rDLine = Application.InputBox(prompt:="Pls select the Dead Line Column.Any one cell", Type:=8)
            
            If Err.Number > 0 Then
                MsgBox "Pls check. Some input is wrong"
                Exit Sub
            End If
            
        Err.Clear
        On Error GoTo 0
        
        lDateC = rDate.Column - rAll(1).Column + 1
        lDLineC = rDLine.Column - rAll(1).Column + 1
        lResC = rRes.Column - rAll(1).Column + 1
        
        Application.ScreenUpdating = False
        
        rAll.SpecialCells(xlCellTypeVisible).Copy
        
        Set wb = ActiveWorkbook
            
        Workbooks.Add
        Worksheets.Add Count:=6
            
        'for datewise filtering
        Worksheets(1).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(1).Range("a1").PasteSpecial xlPasteAll
        
        
        'for dlinewise filtering
        Worksheets(3).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(3).Range("a1").PasteSpecial xlPasteAll
            
        'Copy dates to othersheet for unique
        
        With Worksheets(1)
            .Range(.Cells(1, lDateC), .Cells(1, lDateC).End(xlDown)).Copy
            Set rA = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
        End With
                
        'Remove duplicate to get unique schedule
        With Worksheets(2)
           .Range("a1").PasteSpecial xlPasteAll
          .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
          Set rAU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
        End With
        
       'In third sheet removing the non-highlighted rows
        
        With Worksheets(3)
          Set rD = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
          .Range("N1").Formula = "=SUBTOTAL(3,H:H)"
          
          rD.AutoFilter Field:=1, Operator:=xlFilterNoFill
          Application.Calculate
          lR = .Range("N1").Value
        
          If lR > 1 Then
                .Range(.Range("a2"), .Range("a2").End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp
          End If
            
            .AutoFilterMode = False
         End With
            
        Set outapp = CreateObject("Outlook.Application")
            
        For Each rLO In rAU
            'Filter the date
            rA.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
            
            'converting to date
            dC = DateValue(rLO.Value)
            
            With Worksheets(5)
                .Cells.Clear
                 rA.SpecialCells(xlCellTypeVisible).Copy
                .Range("a5").PasteSpecial xlPasteColumnWidths
                .Range("a5").PasteSpecial xlPasteAll
                
                .Range("A1").Value = "Hello,"
                .Range("A3").Value = "Please find below a list of tasks for today:"
                
               Set rT = .Range("a5").End(xlDown).Offset(4)
                
               rT.Value = "Legend:"
               rT.Offset(1).Interior.ColorIndex = 3
               rT.Offset(2).Interior.ColorIndex = 5
               rT.Offset(1, 1).Value = "'- task type 1"
               rT.Offset(2, 1).Value = "'- task type 2"
               rT.Offset(4).Value = "Best regards,"
               rT.Offset(5).Value = "Milosz"
               
               Set OutMail = outapp.CreateItem(0)
        
                On Error Resume Next
                    With OutMail
                        .To = "name@domain"
                        .CC = ""
                        .BCC = ""
                        .Subject = Format(dC, "dd.mm.yyyy") & " Email of " & Format(dC, "mmm") & Format(dC, "yy")
                        .Importance = olImportanceHigh
                        .DeferredDeliveryTime = dC + TimeValue("6:00")
                        .HTMLBody = RangetoHTML(Worksheets(5).UsedRange)
                        .Save
                    End With
                On Error GoTo 0
                
                .Cells.Clear
              End With
                
                
                'For DLine
                rD.AutoFilter
                rD.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
                
                Application.Calculate
                lR = Worksheets(3).Range("N1").Value
                
                
                'If all are non-highlighted then no urgency mail
                If lR > 1 Then
                    Worksheets(4).Cells.Clear
                    Worksheets(3).Range(Worksheets(3).Cells(1, lDLineC), Worksheets(3).Cells(10000, lDLineC).End(xlUp)).Copy
                    With Worksheets(4)
                        .Range("a1").PasteSpecial xlPasteAll
                        .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
                        Set rDU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
                    End With
                    
                    'Looping for each deadline once
                    For Each rLT In rDU
                      'Looping for each deadline once
                         
                         rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text
                            
                            With Worksheets(6)
                                .Cells.Clear
                                rD.SpecialCells(xlCellTypeVisible).Copy
                                .Range("a5").PasteSpecial xlPasteColumnWidths
                                .Range("a5").PasteSpecial xlPasteAll
                                
                                .Range("A1").Value = "Hello,"
                                .Range("A3").Value = "Please be informed that there's 1h left to deadline for the below type 1 and type 2 task(s):"
                                
                                Set rT = .Range("a5").End(xlDown).Offset(4)
                                
                                rT.Value = "Best Regards"
                                rT.Offset(1, 0).Value = "Milosz"
                                
                                Set OutMail = outapp.CreateItem(0)
                                
                                'On Error Resume Next
                                
                                With OutMail
                                    .To = "name@domain"
                                    .CC = ""
                                    .BCC = ""
                                    .Subject = "1H TO DEADLINE! #Res " & Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(6, lResC), rT.Offset(-3))), " ")
                                    .Importance = olImportanceHigh
                                    .DeferredDeliveryTime = dC + TimeValue(rLT.Text) - TimeValue("1:00:00")
                                    .HTMLBody = RangetoHTML(Worksheets(6).UsedRange)
                                    .Save
                                End With
                                On Error GoTo 0
                                
                                .Cells.Clear
                                End With
                            Next rLT
                 End If
             
            
            Next rLO
            
            Workbooks(Workbooks.Count).Close False
            
            Set OutMail = Nothing
            Set outapp = Nothing
        
    End Sub
    
    


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Thursday, September 22, 2016 4:11 PM
    Answerer

All replies

  • Pls upload a sample file in one drive and share link.

    In 1st sheet give the excel table and in 2nd sheet put the text of mail body/subject/any Email Property you want for each mail one by one.

    Above can be done with little programming of Excel/Outlook but first let us get the details so that we can understand specifics.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, September 20, 2016 6:31 AM
    Answerer
  • Of course! Here it goes (let me know in case I've set up the permissions incorrectly): https://1drv.ms/x/s!AtsoeYc3XMyLpxH9Ht12zpTIWkOs

    Tuesday, September 20, 2016 7:11 AM
  • >>>For instance I am not sure how .DeferredDeliveryTime can obtain data from specific reference cells, and how can I subtract 1H from such a reference. 

    According to your description, you could use DateAdd function to subtract 1 hour:

    Sub Demo()
    
       Debug.Print DateAdd("h", -1, Range("D1"))
    
    End Sub

    The result:

    Tuesday, September 20, 2016 7:58 AM
  • Got It. Hope to revert by few hours.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, September 20, 2016 9:12 AM
    Answerer
  • Link to onedrive

    Test if it helps. This macro will be run based on user input. If ok then can be changed to system date later.

    It filters the date from user input, pastes in copied "Email (2)" sheet,then transfers to outlook with deferred delivery input date 6:00 am.

    That means you can run for any day for testing. In outlook you can check the delayed delivery time.

    After that loops all red/blue deadline and creates separate mail with defrred delivery time 1 hr prior to deadline

    I have used save for mail. It is better not to use "Send".


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, September 20, 2016 3:00 PM
    Answerer
  • I've performed a couple of tests and the programming is superb! Thank you!

    I went through your code to see how it works, since I wanted to tweak the behavior a little bit to make it even more convenient to use. I've gathered just a handful of questions - it'd be really great if you could have a look:

    - for the reminder e-mails the bottom gets cut-off to a various degree (i.e. sometimes there's just the table without "best regards" and at other times my name is missing), not sure why since I can see that part is included in your code. Do you know what might be the cause of this?

    - the ideal solution would be being able to send Emails for all the tasks in the Schedule at once and not just for one specific day. Do you think it could be done?

    - last but not least, is there a way to make the Workbook more "universal" - i.e. right now if I rename a Worksheet, the code will no longer work (without making changes to it also); also some other changes, moving cells etc. would break the code. Furthermore, after running the code, the file has to be cleaned up for further usage (extra Worksheets removed, filters cleared etc.) - do you believe it would be feasible to add this to the program as well, or maybe doing it manually is better here?

    A thousand thanks again, you were really quick to provide this helpful solution!

    Wednesday, September 21, 2016 9:51 AM
  • Yes I did try that, however for some reason it wasn't picked up as date/time format at all and the Emails were sent immediately instead :(

    What I've found in Asadulla Javed's impressive file (link in a post below) is this:

    .DeferredDeliveryTime = dC + TimeValue(rL.Text) - TimeValue("1:00:00")

    With the defitions:

    Dim rL As Range
    Dim dC As Date

    Wednesday, September 21, 2016 10:01 AM
  • Good to see it helped you.

    What I prepared is only skeleton. Many improvement is possible on that. For example I used "Email 2 " sheet and created sheets for test. In final version it is not required. And I think RangeToHtml also can be removed.

    Shall give you my comments for all points raised by you by day closure with an updated version.

    In the mean time can you pls give me the test date for which "Best Regard" or name did not appear.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Wednesday, September 21, 2016 10:31 AM
    Answerer
  • Naturally - it was for 18.09.2016 - in case of the 11:00 CET task there is just "best regards" w/o my name, and in case of the 17:00 tasks both lines are missing (Email ends with the table only).

    Wednesday, September 21, 2016 11:00 AM
  • Tried to update as per requirement.

    1st - No issue now as it is done differently now.

    2nd - Definitely and implemented below. In addition to that below has backward compatibilty also. If you wish to filter and run for particular date or particular set of dates that is also possible.

    3rd - This does not depend on any sheet or cell. You give table, Res , Date, CET column and it acts on that.

    See if it helps.

    For Inputbox of res,date etc pls select any single cell of the column.

    Sub UCreateMailSchedule()
        Dim outapp As Object
        
        Dim rAll As Range
        Dim rDate As Range
        Dim rDLine As Range
        Dim rRes As Range
            
        
        Dim dC As Date
        Dim rA As Range
        Dim rD As Range
        Dim rAU As Range
        Dim rDU As Range
        Dim rLO As Range
        Dim rLT As Range
        Dim rT As Range
        
        
        Dim lR As Long
        Dim lDateC As Long
        Dim lDLineC As Long
        Dim lResC As Long
        
        Dim wb As Workbook
        
        
        'Getting user input
        
        Err.Clear
        On Error Resume Next
            Set rAll = Application.InputBox(prompt:="Pls select the Table", Type:=8)
            Set rRes = Application.InputBox(prompt:="Pls select the Res Column.Any one cell", Type:=8)
            Set rDate = Application.InputBox(prompt:="Pls select the Date Column.Any one cell", Type:=8)
            Set rDLine = Application.InputBox(prompt:="Pls select the Dead Line Column.Any one cell", Type:=8)
            
            If Err.Number > 0 Then
                MsgBox "Pls check. Some input is wrong"
                Exit Sub
            End If
            
        Err.Clear
        On Error GoTo 0
        
        lDateC = rDate.Column - rAll(1).Column + 1
        lDLineC = rDLine.Column - rAll(1).Column + 1
        lResC = rRes.Column - rAll(1).Column + 1
        
        Application.ScreenUpdating = False
        
        rAll.SpecialCells(xlCellTypeVisible).Copy
        
        Set wb = ActiveWorkbook
            
        Workbooks.Add
        Worksheets.Add Count:=6
            
        'for datewise filtering
        Worksheets(1).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(1).Range("a1").PasteSpecial xlPasteAll
        
        
        'for dlinewise filtering
        Worksheets(3).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(3).Range("a1").PasteSpecial xlPasteAll
            
        'Copy dates to othersheet for unique
        
        With Worksheets(1)
            .Range(.Cells(1, lDateC), .Cells(1, lDateC).End(xlDown)).Copy
            Set rA = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
        End With
                
        'Remove duplicate to get unique schedule
        With Worksheets(2)
           .Range("a1").PasteSpecial xlPasteAll
          .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
          Set rAU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
        End With
        
       'In third sheet removing the non-highlighted rows
        
        With Worksheets(3)
          Set rD = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
          rD.AutoFilter Field:=1, Operator:=xlFilterNoFill
          lR = Application.Evaluate("=Subtotal(3," & .Range("a1").EntireColumn.Address & ")")
        
          If lR > 1 Then
                .Range(.Range("a2"), .Range("a2").End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp
          End If
            
            .AutoFilterMode = False
         End With
            
        Set outapp = CreateObject("Outlook.Application")
            
        For Each rLO In rAU
            'Filter the date
            rA.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
            
            'converting to date
            dC = DateValue(rLO.Value)
            
            With Worksheets(5)
                .Cells.Clear
                 rA.SpecialCells(xlCellTypeVisible).Copy
                .Range("a5").PasteSpecial xlPasteColumnWidths
                .Range("a5").PasteSpecial xlPasteAll
                
                .Range("A1").Value = "Hello,"
                .Range("A3").Value = "Please find below a list of tasks for today:"
                
               Set rT = .Range("a5").End(xlDown).Offset(4)
                
               rT.Value = "Legend:"
               rT.Offset(1).Interior.ColorIndex = 3
               rT.Offset(2).Interior.ColorIndex = 5
               rT.Offset(1, 1).Value = "'- task type 1"
               rT.Offset(2, 1).Value = "'- task type 2"
               rT.Offset(4).Value = "Best regards,"
               rT.Offset(5).Value = "Milosz"
               
               Set OutMail = outapp.CreateItem(0)
        
                On Error Resume Next
                    With OutMail
                        .To = "name@domain"
                        .CC = ""
                        .BCC = ""
                        .Subject = Format(dC, "dd.mm.yyyy") & " Email of " & Format(dC, "mmm") & Format(dC, "yy")
                        .Importance = olImportanceHigh
                        .DeferredDeliveryTime = dC + TimeValue("6:00")
                        .HTMLBody = RangetoHTML(Worksheets(5).UsedRange)
                        .Save
                    End With
                On Error GoTo 0
                
                .Cells.Clear
              End With
                
                'For DLine
                rD.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
                
                
                lR = rD.SpecialCells(xlCellTypeVisible).Rows.Count
                
                
                'If all are non-highlighted then no urgency mail
                If lR > 1 Then
                    Worksheets(3).Range(Worksheets(3).Cells(1, lDLineC), Worksheets(3).Cells(10000, lDLineC).End(xlUp)).Copy
                    With Worksheets(4)
                        .Range("a1").PasteSpecial xlPasteAll
                        .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
                        Set rDU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
                    End With
                    
                    'Looping for each deadline once
                    For Each rLT In rDU
                      'Looping for each deadline once
                         rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text
                         rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text
                            
                            
                            With Worksheets(6)
                                .Cells.Clear
                                rD.SpecialCells(xlCellTypeVisible).Copy
                                .Range("a5").PasteSpecial xlPasteColumnWidths
                                .Range("a5").PasteSpecial xlPasteAll
                                
                                .Range("A1").Value = "Hello,"
                                .Range("A3").Value = "Please be informed that there's 1h left to deadline for the below type 1 and type 2 task(s):"
                                
                                Set rT = .Range("a5").End(xlDown).Offset(4)
                                
                                rT.Value = "Best Regards"
                                rT.Offset(1, 0).Value = "Milosz"
                                
                                Set OutMail = outapp.CreateItem(0)
                                
                                'On Error Resume Next
                                
                                With OutMail
                                    .To = "name@domain"
                                    .CC = ""
                                    .BCC = ""
                                    .Subject = "1H TO DEADLINE! #Res " & Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(6, lResC), rT.Offset(-3))), " ")
                                    .Importance = olImportanceHigh
                                    .DeferredDeliveryTime = dC + TimeValue(rLT.Text) - TimeValue("1:00:00")
                                    .HTMLBody = RangetoHTML(Worksheets(6).UsedRange)
                                    .Save
                                End With
                                On Error GoTo 0
                                
                                .Cells.Clear
                                End With
                            Next rLT
                 End If
             
            
            Next rLO
            
            Workbooks(Workbooks.Count).Close False
            
            Set OutMail = Nothing
            Set outapp = Nothing
        
    End Sub
    
    



    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Wednesday, September 21, 2016 4:41 PM
    Answerer
  • Maybe it's something I'm doing wrong on my end but the Emails are all empty, and also they're only generated for the daily schedule (there are no 1h-to-deadline Emails generated in Outlook).

    Nevertheless as you said the macro picks up all the days with correct Email subject and addressee and is very universal. Maybe something I am selecting wrong that gets the empty Email result (and no reminder Emails). Did it work OK on your end?

    My selection criteria below (All from the "Schedule" Worksheet):

    Pls select the Table (A1:K266)
    Pls select the Res Column.Any one cell (A1)
    Pls select the Date Column.Any one cell (K1)
    Pls select the Dead Line Column.Any one cell (J1)

    Not sure what went wrong :(.


    Thursday, September 22, 2016 10:03 AM
  • Actually I overlooked one point.

    Rng.Specialcells(xlcelltypevisible).rows.count

    I always wrongly expect the above is expected to give count of filtered rows. But it only gives count of 1st area. Replaced that part. There were two other problem which sorted out.

    I tested on a small sample that is why I could not find the bugs.Now have run on all table and no issue like above.

    Run it on a different schedule and let me know. Hope some small change can make the code final.

    But pls go through each line. It will help you in tweaking and updating for future. The code may be lengthy but basically it is only Filtering, Copying the filtered data, pasting if more than one row,removing duplicates.

    You can ask if any line is not clear.

    Sub CreateMailScheduleTwentySecondSept()
        Dim outapp As Object
        
        Dim rAll As Range
        Dim rDate As Range
        Dim rDLine As Range
        Dim rRes As Range
            
        
        Dim dC As Date
        Dim rA As Range
        Dim rD As Range
        Dim rAU As Range
        Dim rDU As Range
        Dim rLO As Range
        Dim rLT As Range
        Dim rT As Range
        
        
        Dim lR As Long
        Dim lDateC As Long
        Dim lDLineC As Long
        Dim lResC As Long
        
        Dim wb As Workbook
        
        
        'Getting user input
        
        Err.Clear
        On Error Resume Next
            Set rAll = Application.InputBox(prompt:="Pls select the Table", Type:=8)
            Set rRes = Application.InputBox(prompt:="Pls select the Res Column.Any one cell", Type:=8)
            Set rDate = Application.InputBox(prompt:="Pls select the Date Column.Any one cell", Type:=8)
            Set rDLine = Application.InputBox(prompt:="Pls select the Dead Line Column.Any one cell", Type:=8)
            
            If Err.Number > 0 Then
                MsgBox "Pls check. Some input is wrong"
                Exit Sub
            End If
            
        Err.Clear
        On Error GoTo 0
        
        lDateC = rDate.Column - rAll(1).Column + 1
        lDLineC = rDLine.Column - rAll(1).Column + 1
        lResC = rRes.Column - rAll(1).Column + 1
        
        Application.ScreenUpdating = False
        
        rAll.SpecialCells(xlCellTypeVisible).Copy
        
        Set wb = ActiveWorkbook
            
        Workbooks.Add
        Worksheets.Add Count:=6
            
        'for datewise filtering
        Worksheets(1).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(1).Range("a1").PasteSpecial xlPasteAll
        
        
        'for dlinewise filtering
        Worksheets(3).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(3).Range("a1").PasteSpecial xlPasteAll
            
        'Copy dates to othersheet for unique
        
        With Worksheets(1)
            .Range(.Cells(1, lDateC), .Cells(1, lDateC).End(xlDown)).Copy
            Set rA = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
        End With
                
        'Remove duplicate to get unique schedule
        With Worksheets(2)
           .Range("a1").PasteSpecial xlPasteAll
          .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
          Set rAU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
        End With
        
       'In third sheet removing the non-highlighted rows
        
        With Worksheets(3)
          Set rD = .Range(.Range("A1"), .Range("A1").End(xlToRight).End(xlDown))
          .Range("N1").Formula = "=SUBTOTAL(3,H:H)"
          
          rD.AutoFilter Field:=1, Operator:=xlFilterNoFill
          Application.Calculate
          lR = .Range("N1").Value
        
          If lR > 1 Then
                .Range(.Range("a2"), .Range("a2").End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp
          End If
            
            .AutoFilterMode = False
         End With
            
        Set outapp = CreateObject("Outlook.Application")
            
        For Each rLO In rAU
            'Filter the date
            rA.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
            
            'converting to date
            dC = DateValue(rLO.Value)
            
            With Worksheets(5)
                .Cells.Clear
                 rA.SpecialCells(xlCellTypeVisible).Copy
                .Range("a5").PasteSpecial xlPasteColumnWidths
                .Range("a5").PasteSpecial xlPasteAll
                
                .Range("A1").Value = "Hello,"
                .Range("A3").Value = "Please find below a list of tasks for today:"
                
               Set rT = .Range("a5").End(xlDown).Offset(4)
                
               rT.Value = "Legend:"
               rT.Offset(1).Interior.ColorIndex = 3
               rT.Offset(2).Interior.ColorIndex = 5
               rT.Offset(1, 1).Value = "'- task type 1"
               rT.Offset(2, 1).Value = "'- task type 2"
               rT.Offset(4).Value = "Best regards,"
               rT.Offset(5).Value = "Milosz"
               
               Set OutMail = outapp.CreateItem(0)
        
                On Error Resume Next
                    With OutMail
                        .To = "name@domain"
                        .CC = ""
                        .BCC = ""
                        .Subject = Format(dC, "dd.mm.yyyy") & " Email of " & Format(dC, "mmm") & Format(dC, "yy")
                        .Importance = olImportanceHigh
                        .DeferredDeliveryTime = dC + TimeValue("6:00")
                        .HTMLBody = RangetoHTML(Worksheets(5).UsedRange)
                        .Save
                    End With
                On Error GoTo 0
                
                .Cells.Clear
              End With
                
                
                'For DLine
                rD.AutoFilter
                rD.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
                
                Application.Calculate
                lR = Worksheets(3).Range("N1").Value
                
                
                'If all are non-highlighted then no urgency mail
                If lR > 1 Then
                    Worksheets(4).Cells.Clear
                    Worksheets(3).Range(Worksheets(3).Cells(1, lDLineC), Worksheets(3).Cells(10000, lDLineC).End(xlUp)).Copy
                    With Worksheets(4)
                        .Range("a1").PasteSpecial xlPasteAll
                        .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
                        Set rDU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
                    End With
                    
                    'Looping for each deadline once
                    For Each rLT In rDU
                      'Looping for each deadline once
                         
                         rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text
                            
                            With Worksheets(6)
                                .Cells.Clear
                                rD.SpecialCells(xlCellTypeVisible).Copy
                                .Range("a5").PasteSpecial xlPasteColumnWidths
                                .Range("a5").PasteSpecial xlPasteAll
                                
                                .Range("A1").Value = "Hello,"
                                .Range("A3").Value = "Please be informed that there's 1h left to deadline for the below type 1 and type 2 task(s):"
                                
                                Set rT = .Range("a5").End(xlDown).Offset(4)
                                
                                rT.Value = "Best Regards"
                                rT.Offset(1, 0).Value = "Milosz"
                                
                                Set OutMail = outapp.CreateItem(0)
                                
                                'On Error Resume Next
                                
                                With OutMail
                                    .To = "name@domain"
                                    .CC = ""
                                    .BCC = ""
                                    .Subject = "1H TO DEADLINE! #Res " & Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(6, lResC), rT.Offset(-3))), " ")
                                    .Importance = olImportanceHigh
                                    .DeferredDeliveryTime = dC + TimeValue(rLT.Text) - TimeValue("1:00:00")
                                    .HTMLBody = RangetoHTML(Worksheets(6).UsedRange)
                                    .Save
                                End With
                                On Error GoTo 0
                                
                                .Cells.Clear
                                End With
                            Next rLT
                 End If
             
            
            Next rLO
            
            Workbooks(Workbooks.Count).Close False
            
            Set OutMail = Nothing
            Set outapp = Nothing
        
    End Sub
    
    


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Thursday, September 22, 2016 4:11 PM
    Answerer
  • Your code works beautifully!

    Thank you for sharing your expertise - I don't think any further changes are needed at all at this stage.

    One curious case still for me to solve - I've pasted an entirely new schedule and ran the macro. But for a (yet) unknown reason the below error occurred:

    Run-time error '1004': Application-defined or object defined error

    As it is a bit of a catch-all error in VBA, it didn't really tell me much. But what I noticed is that Emails got generated just up until October 6th. So I though to exclude just this one single day from the schedule and... it worked.

    Strange enough, right?

    So now I will be trying to figure out in what way is this specific date different from all the others in my timetable. I will share my findings here for your reference as it may have some relevance for similar future projects.

    Thank you once again and wish you a good day ahead :).

    Friday, September 23, 2016 8:36 AM
  • It will be very pleasing for me that you take a grip on this code and solve the issue. But pls share the below ...and paste an image after filtering the 6th Oct date in of your new schedule

    *********

    Tell me at which line error is coming (When the message appears press Debug).I guess it is at last part where deadline mail is generated.

    What is the time formatting or date formatting of Deadline or Date column

    Is there any odd time like 12:00 AM ?

    **********

    One Update

    In below two line used N1/H:H cell of new workbook for getting total filtered rows. It may create problem if your schedule is more than 11 column or less than 8 column.

    Solution: Replace N with any faraway column like AB and H:H with A:A

    .Range("N1").Formula = "=SUBTOTAL(3,H:H)"

    Same for below

          lR = .Range("N1").Value



    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol


    Friday, September 23, 2016 9:13 AM
    Answerer
  • Thanks for the update!

    Below are the details you requested.

    After clicking debug it shows me this line in yellow:

    Set rT = .Range("a5").End(xlDown).Offset(4)

    No odd times, date and time formatting is identical as for the rest of the schedule.

    Furthermore: I checked and if I try to run the macro for October 6th only, it generated the daily schedule email (but not the reminder emails) and gives no error (despite working incorrectly). Only when I add another line (even a single one, for example the first task for October 7th) the error appears, but the result is exactly the same - I get one daily schedule for October 6th and nothing else.

    Sadly I am unable to post images here at the moment, will have to wait till my account get 'verified', so sending you the link to the requested screenshot: https://1drv.ms/u/s!AtsoeYc3XMyLpxRX8skHSTNq5S61

    Still trying to figure this one out.

    Friday, September 23, 2016 11:40 AM
  • Pls share me the sample data. If possible 2 - 3 sets.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Friday, September 23, 2016 12:10 PM
    Answerer
  • Link: https://1drv.ms/x/s!AtsoeYc3XMyLpxUeEl0uE_AQLTqI

    Let me know if this is enough.

    Friday, September 23, 2016 12:37 PM
  • See now. Did you use same sample as shared with me ? At first it did not work for any deadline. Becuase I used "Subtotal(3,H:H)" for getting count of filtered rows. And in your case all description is blank so it returned 1 for all and if only 1 row is filetered then it has no deadline. Corrected that.

    Not sure why but in my PC your date shown as 03 10 2016. And it was not in date format. Check if Subject is correctly.

    Earlier in #Res column unique data was there. So I used in deadline subject. But if it is Team then it looks Odd. Revert what acually will be in #Res column.

    And ensure that Date and Deadline be always non-blank.

    Sub CreateMailScheduleTwentyThirdSept()
        
        Dim outapp As Object
        
        Dim rAll As Range
        Dim rDate As Range
        Dim rDLine As Range
        Dim rRes As Range
            
        
        Dim dC As Date
        Dim rA As Range
        Dim rD As Range
        Dim rAU As Range
        Dim rDU As Range
        Dim rLO As Range
        Dim rLT As Range
        Dim rT As Range
        
        
        Dim lR As Long
        Dim lDateC As Long
        Dim lDLineC As Long
        Dim lResC As Long
        
        Dim wb As Workbook
        
        
        'Getting user input
        
        Err.Clear
        On Error Resume Next
        
            'Pls ensure that Date,Deadline and Res in not blank
            Set rAll = Application.InputBox(prompt:="Pls select the Table", Type:=8)
            Set rRes = Application.InputBox(prompt:="Pls select the Unique Column.This will appear in subject.Any one cell", Type:=8)
            Set rDate = Application.InputBox(prompt:="Pls select the Date Column.Any one cell", Type:=8)
            Set rDLine = Application.InputBox(prompt:="Pls select the Dead Line Column.Any one cell", Type:=8)
                    
            If Err.Number > 0 Then
                MsgBox "Pls check. Some input is wrong"
                Exit Sub
            End If
            
            
        Err.Clear
        On Error GoTo 0
        
        lDateC = rDate.Column - rAll(1).Column + 1
        lDLineC = rDLine.Column - rAll(1).Column + 1
        lResC = rRes.Column - rAll(1).Column + 1
        
        Application.ScreenUpdating = False
        
        rAll.SpecialCells(xlCellTypeVisible).Copy
        
        Set wb = ActiveWorkbook
            
        Workbooks.Add
        Worksheets.Add Count:=6
            
        'for datewise filtering
        Worksheets(1).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(1).Range("a1").PasteSpecial xlPasteAll
        
        
        'for dlinewise filtering
        Worksheets(3).Range("a1").PasteSpecial xlPasteColumnWidths
        Worksheets(3).Range("a1").PasteSpecial xlPasteAll
            
        'Copy dates to othersheet for unique
        
        With Worksheets(1)
            .Range(.Cells(1, lDateC), .Cells(1, lDateC).End(xlDown)).Copy
            Set rA = .UsedRange
        End With
                
        'Remove duplicate to get unique schedule
        With Worksheets(2)
           .Range("a1").PasteSpecial xlPasteAll
          .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
          Set rAU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
        End With
        
       'In third sheet removing the non-highlighted rows
        
        With Worksheets(3)
          Set rD = .UsedRange
          .Cells(1, rAll.Columns.Count + 10).Formula = "=SUBTOTAL(3," & .Cells(1, lDateC).EntireColumn.Address & ")"
          
          rD.AutoFilter Field:=1, Operator:=xlFilterNoFill
          Application.Calculate
          lR = .Cells(1, rAll.Columns.Count + 10).Value
        
          If lR > 1 Then
                .Range(.Cells(2, lDateC), .Cells(2, lDateC).End(xlDown)).SpecialCells(xlCellTypeVisible).EntireRow.Delete xlUp
          End If
            
            .AutoFilterMode = False
         End With
            
        Set outapp = CreateObject("Outlook.Application")
            
        For Each rLO In rAU
            'Filter the date
            rA.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
            
            'converting to date
            dC = DateValue(rLO.Value)
            
            With Worksheets(5)
                .Cells.Clear
                 rA.SpecialCells(xlCellTypeVisible).Copy
                .Range("a5").PasteSpecial xlPasteColumnWidths
                .Range("a5").PasteSpecial xlPasteAll
                
                .Range("A1").Value = "Hello,"
                .Range("A3").Value = "Please find below a list of tasks for today:"
                
               Set rT = .Range("a5").End(xlDown).Offset(4)
                
               rT.Value = "Legend:"
               rT.Offset(1).Interior.ColorIndex = 3
               rT.Offset(2).Interior.ColorIndex = 5
               rT.Offset(1, 1).Value = "'- task type 1"
               rT.Offset(2, 1).Value = "'- task type 2"
               rT.Offset(4).Value = "Best regards,"
               rT.Offset(5).Value = "Milosz"
               
               Set OutMail = outapp.CreateItem(0)
        
                On Error Resume Next
                    With OutMail
                        .To = "name@domain"
                        .CC = ""
                        .BCC = ""
                        .Subject = Format(dC, "dd.mm.yyyy") & " Email of " & Format(dC, "mmm") & Format(dC, "yy")
                        .Importance = olImportanceHigh
                        .DeferredDeliveryTime = dC + TimeValue("6:00")
                        .HTMLBody = RangetoHTML(Worksheets(5).UsedRange)
                        .Save
                    End With
                On Error GoTo 0
                
                .Cells.Clear
              End With
                
                
                'For DLine
                rD.AutoFilter
                rD.AutoFilter Field:=lDateC, Criteria1:=rLO.Text
                
                Application.Calculate
                lR = Worksheets(3).Cells(1, rAll.Columns.Count + 10).Value
                
                
                'If all are non-highlighted then no urgency mail
                If lR > 1 Then
                    Worksheets(4).Cells.Clear
                    Worksheets(3).Range(Worksheets(3).Cells(1, lDLineC), Worksheets(3).Cells(10000, lDLineC).End(xlUp)).Copy
                    With Worksheets(4)
                        .Range("a1").PasteSpecial xlPasteAll
                        .Range(.Range("a1"), .Range("a1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
                        Set rDU = .Range(.Range("a2"), .Range("a10000").End(xlUp))
                    End With
                    
                    'Looping for each deadline once
                    For Each rLT In rDU
            
                         
                         rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text
                            
                            With Worksheets(6)
                                .Cells.Clear
                                rD.SpecialCells(xlCellTypeVisible).Copy
                                .Range("a6").PasteSpecial xlPasteColumnWidths
                                .Range("a6").PasteSpecial xlPasteAll
                                
                                .Range("A1").Value = "Hello,"
                                .Range("A3").Value = "Please be informed that there's 1h left to deadline"
                                .Range("A4").Value = "for the below type 1 and type 2 task(s):"
                                
                                Set rT = .Range("a6").End(xlDown).Offset(4)
                                
                                rT.Value = "Best Regards"
                                rT.Offset(1, 0).Value = "Milosz"
                                
                                Set OutMail = outapp.CreateItem(0)
                                
                                On Error Resume Next
                                
                                With OutMail
                                    .To = "name@domain"
                                    .CC = ""
                                    .BCC = ""
                                    .Subject = "1H TO DEADLINE! #Res " & Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(7, lResC), Worksheets(6).Cells(rT.Offset(-3).Row, lResC))), " ")
                                    .Importance = olImportanceHigh
                                    .DeferredDeliveryTime = dC + TimeValue(rLT.Text) - TimeValue("1:00:00")
                                    .HTMLBody = RangetoHTML(Worksheets(6).UsedRange)
                                    .Save
                                End With
                                On Error GoTo 0
                                
                                .Cells.Clear
                                End With
                            Next rLT
                 End If
             
            
            Next rLO
            
            Workbooks(Workbooks.Count).Close False
            
            Set OutMail = Nothing
            Set outapp = Nothing
        
    End Sub
    
    









    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Friday, September 23, 2016 2:20 PM
    Answerer
  • Yes I did use the same one :) the date is just in European format (DD MM YYYY), but it gets picked up correctly, so no issues there.

    I modified the #Res column, but yes in practice it will contain unique data only - for now the subject can look funny as long as it shows correct output.

    I tried again on the same sample with the code you provided, but I get the same error on the same line and the same date (October 6th- just the daily Email, no reminders and the script stops).

    As it worked correctly on your end then there's a huge probability that it has nothing to do with the programming. Maybe I should try on some other version of Excel (using 2007)... I seem to be again at a loss to figure out why this doesn't work.

    What is really bewildering is the fact that the error occurred now again on the same date, even though the input was changed.


    Monday, September 26, 2016 5:55 AM
  • I use 2007. What version you tested ?

    It is unfortunate I could not reproduc the issue.

    Filter the 6th Date - Change the date to 7th or some other then Run code


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Monday, September 26, 2016 6:16 AM
    Answerer
  • Now I tested also 2010, before that 2007 which I normally use.

    I changed to 5th and it still results in an error. Then to 7th and also -> error.

    Nevertheless I believe I got it!

    I've generated an entirely new sample input and run the code. The error was now for 31.10.2016 instead! And only 1 thing those days had in common: tasks time span.

    For 6th Oct it was 10h, so more than for any other date we tested.

    For 31st Oct it was even more (around 17h to be exact).

    Seeing this I took the "3 Samples" file I gave you before weekend and removed only 1 single line: the task with October 6th 2016, 8:00 CET deadline, effectively reducing tasks time span from 10h to 2h.

    After this one modification everything worked perfectly fine.

    So now my question to you is - would you be able to tell, based on the aforementioned findings, how is it that the time span can crush the script like that?

    Even though I've now found the what I still don't get the why... :)


    Monday, September 26, 2016 7:12 AM
  • In the last line you will find

    Worksbooks......Close

    Remove the line. And run the code by pressing F8 from VB Editore (From Excel - >ALt+F11) . See what is appearing in sixth sheet. For each dead line you will see one body is created which is used in deadline mail.

    Share the input. As I could not reproduce the issue here it seems to be related with Outlook also.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Monday, September 26, 2016 8:07 AM
    Answerer
  • In the sixth sheet I can see all the unique dates in consecutive order. They're all in Date format (D MM YYYY).

    I used "Sample 2" tab from "3 Samples" file uploaded before weekend. In this case that is my result in sixth sheet you referred to:

    Date
    5 10 2016
    6 10 2016
    7 10 2016

    I also used another sample and the result was analogically the same.


    Monday, September 26, 2016 9:09 AM
  • No. Go to the sixth sheet. You are referring to 5th. In Sixth sheet you will see same structure of mail body which passed to RangeToHtml.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Monday, September 26, 2016 10:20 AM
    Answerer
  • OK I guess you mean the Sheet2, here's the screenshot (there's no data below the headers):

    https://1drv.ms/u/s!AtsoeYc3XMyLpxi9i2ZF0FLiJz_A

    And just FYR here's the screen from Sheet6 you referred to which contains Dates:

    https://1drv.ms/u/s!AtsoeYc3XMyLpxd0ELPfm3FjJ6B3

    Let me know in case anything else would be helpful.

    Monday, September 26, 2016 10:57 AM
  • I do not mean sheet name. It is not possible for me to know what will be sheet name as excel determines as per it's own system.

    6th means 6th sheet from left.

    Pls see my last post. I mentioned...

    "In the last line you will find

    Worksbooks......Close

    Remove the line. And run the code by pressing F8 constantly from VB Editor (From Excel - >ALt+F11) . See what is appearing in sixth sheet. For each dead line you will see one body is created which is used in deadline mail.

    Share the input. As I could not reproduce the issue here it seems to be related with Outlook also."

    It will help you in knowing the inner working of code.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Monday, September 26, 2016 7:34 PM
    Answerer
  • Here's the same link from yesterday, I think that would be it: https://1drv.ms/u/s!AtsoeYc3XMyLpxi9i2ZF0FLiJz_A

    There seems to be no data below headers. And script stops with error at the same line using F8:

    Set rT = .Range("a5").End(xlDown).Offset(4)

    Oh, and also it may interest you that removing the mentioned line (Worksbooks......Close) to see these sheets is not needed, because when the script crashes with an error, these sheets will remain open.


    Tuesday, September 27, 2016 5:19 AM
  • If I could have reproduced the scenario it would have been solved till now. Any way pls try following below..

    1. ALthogh I know but still want to know are you using the lastest code with Sub Name "Sub CreateMailScheduleTwentyThirdSept()"

    2. F8 is for debugging. I request you to press f8 constantly and when the new workbook is created by my code watch all sheet how it is changing with each line. Below is summary of working.

    In first sheet of new workbook the selected data will be pasted at A1. In 2nd Sheet will be unique dates for the selected data. In 3rd Sheet will be the only rows which is highlighted in your selected data. (Where deadline mail required). These 3 sheet is constant for single run.

    Now for each unique date in 2nd sheet, the 1st sheet is filtered and mail for daily schedule created in 5th Sheet. Then Sheet 3 is filtered with same date, if any deadline is there the DeadLine is copied to 4th Sheet. If no deadline continue to next date. The 4th Sheet will change for each unique date.

    Now the 4th sheet deadlines are made unique by remove duplicate. Then for each deadline, sheet3 is filtered and in 6th sheet the data pasted.

    ***************************************************

    For present situation The Time Span is reason need not be verified. If all other option exhausted then we have to think that.

    Check from 1st to 6th sheet after each pressing of F8. It will help you in long term also. Whenever you see that error appeared, watch all sheet and note the difference between sheet data created by other date and the "6 10 2016" date.

    Then press End. And send me link of the workbook.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, September 27, 2016 7:17 AM
    Answerer
  • The filtering is the culprit.

    After pressing F8 for this step: rD.AutoFilter Field:=lDLineC, Criteria1:=rLT.Text

    It should give 8:00 CET deadline task happening on 6 Oct 2016 in 3rd sheet that then would get pasted to 6th sheet, but instead it is blank (i.e. headers only).

    Link to input Workbook: https://1drv.ms/x/s!AtsoeYc3XMyLpxkuQcWUah5X2YIQ

    Link to output Workbook till error: https://1drv.ms/x/s!AtsoeYc3XMyLpxqkcctjTnwGwMYp


    Tuesday, September 27, 2016 8:57 AM
  • Change the above line with below...

    rD.AutoFilter Field:=lDLineC, Criteria1:=Format(rLT.Value, rDLine.NumberFormat)

    In the shared file Book1 you will see that excel wants to filter 08:00 whereas cell data is 8:00. As a result no output. It is probably due to using rLT.Text which is supposed to take the form as displayed in cell but for some reason it is not doing. Cell is formatted with h:mm but it is showing hh:mm.

    Replaced that with exact formatting of the column which user will give while selecting deadline column.

    See if it works.

    Caution:

    And pls ensure that all cells of deadline column must have same formatting. All cells of Date column must have same formatting.

    When input box asks for selecting one cell for date or deadline, select one cell which has actual data.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Tuesday, September 27, 2016 2:34 PM
    Answerer
  • Yes, this is it! Thank you!

    Would you have enough patience to help me with just one more thing in this file?

    In case you would, here it goes:

    For reminder Emails containing only 1 task the header "#Res" gets copied into subject, so the result is "#Res #Res Team A", i.e. there's double entry - one from the code and one from the header. Do you know why?

    EDIT: for some reminder Emails subject is not appearing. I cannot use the debugging, because it doesn't show me the Email creation process. The values seem alright (I did the step-by-step observation of how the sheets change...), maybe it's this line that's somehow not working for some of the input:

    .Subject = "1H TO DEADLINE! #Res " & Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(7, lResC), Worksheets(6).Cells(rT.Offset(-3).Row, lResC))), " ")

    EDIT 2: When I remove the latter part of the aforementioned line, and leave it as .Subject = "1H TO DEADLINE!" it works fine. I'm going to play aroung with it a bit, maybe I can figure it out - will post the results here soon in any case.

    EDIT 3: Solved it! I reduced the Offset to -1 and now it's OK - both issues are gone, the one with double #Res entry and the one with empty subject :) Many thanks again for your expert help, I really appreciate your patience and good advice!
    Wednesday, September 28, 2016 10:27 AM
  • It is very nice to see that the code is working for you. Play around the code as it will help you in maintaining the code and make it scalable for future enhancements.

    Below is explanation of line

     Join(Application.Transpose(Worksheets(6).Range(Worksheets(6).Cells(7, lResC), Worksheets(6).Cells(rT.Offset(-3).Row, lResC))), " "

    The range is the data which is pasted in 6th Sheet. This range is two dimensional array (for row and column). TRANSPOSE is normally used to convert between row and column. But it has one side effect. It reduces two dimensional range to one dimensional array in the process. Here this side effect is utilised. JOIN takes one dimension array and creates a string with the elements of array separating them with Delimiter argment. Here it is space. Then that string is used in Subject.

    We can use loop also as alternative.

    **********************************************

    In future probably you may think

    1) to mail different ID based on task

    2) to vary the 1H to some flexible hours.

    3) to add more type of task instead of Type1,Type2

    4) to mail for same task 2-3 times. First before 1 H , 2nd before Half hour and text of mail will show more urgency.

    Try to understand the code and you can do all above with slight modification. The code is basically filtering, getting unique item, looping each unique item, pasting.

    All the best.


    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Wednesday, September 28, 2016 2:28 PM
    Answerer
  • Yes, that is very true! Thank you for the exhaustive explanation and on-the-spot suggestions :)

    All the best,

    Miłosz

    Thursday, September 29, 2016 12:57 PM