Macro sending e-mail to one or more consignees

[JOJESS]

Hi all,

I have a pivot table. Below is a snap picture from it. What I need, is an e-mail to be sent if a unique date (for instance 2017-12-12) have more than two equal times (for instance 13:45).

If not possible, I would at least need to have a color indicator that highlights those rows.

Thanks for the ones having this knowledge and sharing it.

KR Jessica

__________________________________________

2017-12-12	N/A	B066325C
2017-12-12	1345	B068160A
2017-12-12	1345	B068391A
2017-12-12	1345	B068160B
2017-12-12	745	B068268BG
2017-12-12	745	B068268CG

<tbody>
</tbody><colgroup><col><col><col></colgroup>

2017-12-12	N/A	B066325C
2017-12-12	1345	B068160A
2017-12-12	1345	B068391A
2017-12-12	1345	B068160B
2017-12-12	745	B068268BG
2017-12-12	745	B068268CG

<tbody>
</tbody><colgroup><col><col><col></colgroup>

 

[Logit]

.
Here's one way:

Option Explicit
Sub Macro1()
     
    Const lngStartRow As Long = 1 'Starting Row number for the data. Change to suit.
    Const strStartCol As String = "B" 'Starting column letter for the duplicates. Change to suit.
     
    Dim lngLastCol    As Long
    Dim lngMyCol      As Long
    Dim lngLastRow    As Long
    Dim lngMyRow      As Long
    Dim strMyCol      As String
    Dim strPK         As String 'Primary Key
    Dim xlnCalcMethod As XlCalculation
     
    Application.ScreenUpdating = False
         
     'Note the sheet must have data in it or the next lines will error out!!
    lngLastCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     
     'Remove any previous duplicate highlighting
    strMyCol = Left(Cells(1, lngLastCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngLastCol).Address(True, False)) - 1)
    Range(Cells(lngStartRow, strStartCol), Cells(lngLastRow, strMyCol)).Interior.Color = xlNone
     
     'Create Primary Key formula
    For lngMyCol = Asc(strStartCol) - 64 To lngLastCol
        strMyCol = Left(Cells(1, lngMyCol).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngMyCol).Address(True, False)) - 1)
        If lngMyCol = Asc(strStartCol) - 64 Then
            strPK = "=" & strMyCol & lngStartRow
        Else
            strPK = strPK & "&" & strMyCol & lngStartRow
        End If
    Next lngMyCol
     
    strMyCol = Left(Cells(1, lngLastCol + 1).Address(True, False), Application.WorksheetFunction.Search("$", Cells(1, lngLastCol + 1).Address(True, False)) - 1)
     
     'Copy Primary Key formula down dataset
    Range(Cells(lngStartRow, strMyCol), Cells(lngLastRow, strMyCol)).Formula = strPK
     
     'Loop through Primary Key field and highlight duplicates
    For lngMyRow = lngStartRow To lngLastRow
        If Evaluate("COUNTIF(" & Range(strMyCol & lngStartRow & ":" & strMyCol & lngStartRow & lngLastRow).Address(True, True) & "," & Range(strMyCol & lngMyRow).Address(False, True) & ")") > 1 Then
           Range(Cells(lngMyRow, Asc(strStartCol) - 64), Cells(lngMyRow, lngLastCol)).Interior.Color = RGB(255, 255, 0) 'Highlight duplicates in yellow. Change to suit.
        End If
    Next lngMyRow
        
    'Delete helper column
    Columns(strMyCol).EntireColumn.Delete
     
     
    Application.ScreenUpdating = True
         
  
End Sub