Excel Macro to select the latest date

Hi,

I have a excel sheet with 6 sheets (1,2,3,4,5,6). The macro for the excel sheet would select all the rows with status 'In Progress' in column P across all the sheets and will send out an email.

There are two problems I am facing here:
1. When an email is created the rows for each sheet is displayed one below the other. However the row/column size is not standard. Certain cells are big in size and hence the representation is not looking good.

2. In all the sheets column Q = Remarks. Here each cell has data based on dates.
for example
[2/2/2010 - DAta data data
1/1/2020 - Data1 data1 data1]

What code should i write so that only the topmost date and the related data is selected from a particular cell?


PLease find the macro below for your reference:

Option Explicit

Sub Mail_Sheet_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim ProgressRNG As Range
Dim ProgressRNG2 As Range
Dim ProgressRNG3 As Range
Dim ProgressRNG4 As Range
Dim ProgressRNG5 As Range
Dim ProgressRNG6 As Range

Dim OutApp As Object
Dim OutMail As Object
Dim LastRow As Long

Application.EnableEvents = False
Application.ScreenUpdating = False

With Sheets("1")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Sheets("2")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG2 = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Sheets("3")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG3 = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Sheets("4")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG4 = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Sheets("5")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG5 = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Sheets("6")
.AutoFilterMode = False
LastRow = .Cells.Find("*", Cells(.Rows.Count, .Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
Set ProgressRNG6 = .Range("A1:A" & LastRow) _
.SpecialCells(xlCellTypeVisible).EntireRow
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = "@gmail.in"
.CC = ""
.BCC = ""
.Subject = "Status as on "
.HTMLBody = "1" & RangetoHTML(ProgressRNG) & "<br>" & "2" & RangetoHTML(ProgressRNG2) & "<br>" & "<br>" & "3" & RangetoHTML(ProgressRNG3) & "<br>" & "3" & RangetoHTML(ProgressRNG4) & "<br>" & "5" & RangetoHTML(ProgressRNG5) & "<br>" & "6" & RangetoHTML(ProgressRNG6)

.Display 'or use .Send
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Sheets("1").AutoFilterMode = False
Sheets("2").AutoFilterMode = False
Sheets("3").AutoFilterMode = False
Sheets("4").AutoFilterMode = False
Sheets("5").AutoFilterMode = False
Sheets("6").AutoFilterMode = False
Set OutMail = Nothing
Set OutApp = Nothing
Set ProgressRNG = Nothing
Set ProgressRNG2 = Nothing
Set ProgressRNG3 = Nothing
Set ProgressRNG4 = Nothing
Set ProgressRNG5 = Nothing
Set ProgressRNG6 = Nothing
End Sub