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 = "
.HTMLBody = " & RangetoHTML(ProgressRNG) & "<br>" & " & RangetoHTML(ProgressRNG) & " & RangetoHTML(ProgressRNG2) & "<br>" & "<br>" & " & RangetoHTML(ProgressRNG2) & " & RangetoHTML(ProgressRNG3) & "<br>" & " & " & RangetoHTML(ProgressRNG4) & "<br>" & " & " & RangetoHTML(ProgressRNG5) & "<br>" & " & RangetoHTML(ProgressRNG3) & " & RangetoHTML(ProgressRNG6)

.Display 'or use .Send
End With
On Error Go to 0

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

Sheets(" & ").AutoFilterMode = False
Sheets(" & RangetoHTML(ProgressRNG4) & ").AutoFilterMode = False
Sheets(" & ").AutoFilterMode = False
Sheets(" & RangetoHTML(ProgressRNG5) & ").AutoFilterMode = False
Sheets(" & ").AutoFilterMode = False
Sheets(" & RangetoHTML(ProgressRNG6)

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

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

Sheets(").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

1) Please delete those empty MODULES. Going on a code hunt is a pain in the...

2) I gave you a much more succinct version of this macro in this thread:

https://www.askmehelpdesk.com/spreadsheets/excel-macro-needed-467388.html

... in the last post. The trick to getting them all in the same column width/format is to copy all the various sheet ranges to a single TEMP sheets, then do the HTML stuff.

Here's the same macro I gave already with your new sheet names inserted. I ran it on your sheet above and it worked perfectly.

Option Explicit

Sub Mail_Sheet_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim ws As Worksheet
Dim wsTemp As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim LastRow As Long
Dim NextRow As Long

Application.EnableEvents = False
Application.ScreenUpdating = False

If Not Evaluate("ISREF(Temp!A1)") Then
Worksheets.Add(After:=Worksheets(Worksheets.Count) ).Name = "Temp"
Range("A1") = "Data"
Else
Sheets("Temp").Range("A2:Z" & Rows.Count).Clear
End If

NextRow = 2

Set wsTemp = Sheets("Temp")

For Each ws In Worksheets(Array("1", "2", "3", "4", "5", "6"))
With ws
.AutoFilterMode = False
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
LastRow = .Range("P" & Rows.Count).End(xlUp).Row
If LastRow > 1 Then
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow _
.Copy wsTemp.Range("A" & NextRow)
NextRow = wsTemp.Range("A" & Rows.Count).End(xlUp).Row + 1
End If
.AutoFilterMode = False
End With
Next ws

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

On Error Resume Next
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Status for IN PROGRESS as on " & Format(Date, "MM-DD-YY")
.HTMLBody = RangetoHTML(wsTemp.UsedRange)
.Display 'or use .Send
'.send
End With
On Error GoTo 0

Application.DisplayAlerts = False
wsTemp.Delete
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Thanks a lot... that solves my first problem.. any luck with the second query?

Once the data is consolidated onto the TEMP sheet, before the HTML is created, we can run through all the column Q values and delete everything after the first line feed.


Option Explicit

Sub Mail_Sheet_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
Dim ws As Worksheet
Dim wsTemp As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim LastRow As Long
Dim NextRow As Long
Dim Rw As Long

Application.EnableEvents = False
Application.ScreenUpdating = False

If Not Evaluate("ISREF(Temp!A1)") Then
Worksheets.Add(After:=Worksheets(Worksheets.Count) ).Name = "Temp"
Range("A1") = "Data"
Else
Sheets("Temp").Range("A2:Z" & Rows.Count).Clear
End If

NextRow = 2

Set wsTemp = Sheets("Temp")

For Each ws In Worksheets(Array("1", "2", "3", "4", "5", "6"))
With ws
.AutoFilterMode = False
.Range("P:P").AutoFilter Field:=1, Criteria1:="In Progress"
LastRow = .Range("P" & Rows.Count).End(xlUp).Row
If LastRow > 1 Then
.Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow _
.Copy wsTemp.Range("A" & NextRow)
NextRow = wsTemp.Range("A" & Rows.Count).End(xlUp).Row + 1
End If
.AutoFilterMode = False
End With
Next ws

With wsTemp
.Columns.AutoFit
For Rw = 3 To NextRow
If InStr(Range("Q" & Rw), Chr(10)) > 0 Then _
Range("Q" & Rw) = Left(Range("Q" & Rw), _
InStr(Range("Q" & Rw), Chr(10)) - 1)
Next Rw
End With

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

On Error Resume Next
With OutMail
.To = "[email protected]"
.CC = ""
.BCC = ""
.Subject = "Status for IN PROGRESS as on " & Format(Date, "MM-DD-YY")
.HTMLBody = RangetoHTML(wsTemp.UsedRange)
.Display 'or use .Send
'.send
End With
On Error GoTo 0

Application.DisplayAlerts = False
wsTemp.Delete
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Thanks a ton! Thank you very much..