If condition for check all the rows

Dear Team,


I am having multiple sheet on my workbook.I will update details on Sheet "Data" manually. Based on the value the particular sheet will open and copy the range and send to email automatically.


On my below code i done it for only one specified row. But i want it to check all the updated rows and send email based on the condition met.

Code:

---

Option Explicit

---

Code:

---

Sub EmailTrainingValue()
 
 'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
Dim MailSub As String
Dim MailTxt As String
Dim MailTo As String
Dim lRow As Long
Dim lCol As Long
Dim MR As Range, Cell As Range
Dim mySheet As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
 
 
 '-----------------------Creatte Email List---------------
 Dim sh As Worksheet, rng As Range, c As Range, s As String
 Set sh = Sheets("Data")
 s = ""
 With sh
 Set rng = .Range("O9") '.SpecialCells(xlCellTypeConstants, 23)
 For Each c In rng.Cells
 s = s & c & ";"
 Next c
 End With
 s = Left(s, Len(s) - 1)
 '--------------------End Email List-----------------------
 '************************************************* ********
 'Set email details; Comment out if not required
 MailTo = s
 Const MailCC = "some2@someone.com"
 Const MailBCC = "some3@someone.com"
 MailSub = " Oil Service for your " & mySheet & " Machine"
 MailTxt = "Dear Sir," & vbLf & vbLf & "Please fine here with attached Training conducted details on for "
'Print '************************************************* ********
 
 'Turns off screen updating
 Application.ScreenUpdating = False
 
 'Makes a copy of the active sheet and save it to a temporary file
 Dim wks As Worksheet
 
 mySheet = Worksheets("Data").Cells(9, 2).Value
 TempFilePath = Environ$("temp") & "\"
 TempFileName = mySheet & "Service details.pdf"
 FileFullPath = TempFilePath & TempFileName
 lCol = Cells(9, Columns.Count).End(xlToLeft).Column
 Set MR = Range("C9:N9" & lCol)
 For Each Cell In MR
 If Cell.Value > 25 And Cell.Value <= 50 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B2:F24").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 ElseIf Cell.Value > 400 And Cell.Value <= 500 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B26:F65").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 ElseIf Cell.Value > 900 And Cell.Value <= 1000 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B67:F115").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 End If
 On Error GoTo 0
 Next Cell
 
 
 'Creates and shows the outlook mail item
 Set oApp = CreateObject("Outlook.Application")
 Set oMail = oApp.CreateItem(0)
 With oMail
 .To = MailTo
 .Subject = MailSub
 .Body = MailTxt
 .Attachments.Add FileFullPath
 .Display
 End With
 'Restores screen updating and release Outlook
 Application.ScreenUpdating = True
 Set oMail = Nothing
 Set oApp = Nothing
End Sub

---

Can any one help me for comlete my requirement.


I am attaching my file here for your reference

Seems like this should work. HTH. Dave

Code:

---

Sub EmailTrainingValue()
 'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
Dim MailSub As String
Dim MailTxt As String
Dim MailTo As String
Dim lRow As Long
Dim lCol As Long
Dim MR As Range, Cell As Range
Dim mySheet As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
Dim SplitS As Variant, Cnt As Integer
 
 
 '-----------------------Creatte Email List---------------
 Dim sh As Worksheet, rng As Range, c As Range, s As String
 Set sh = Sheets("Data")
 s = ""
 With sh
 Set rng = .Range("O9") '.SpecialCells(xlCellTypeConstants, 23)
 For Each c In rng.Cells
 s = s & c & ";"
 Next c
End With
SplitS = Split(s, ";")
For Cnt = LBound(SplitS) To UBound(SplitS) - 1
 'Set email details; Comment out if not required
 MailTo = SplitS(Cnt)
 Const MailCC = "some2@someone.com"
 Const MailBCC = "some3@someone.com"
 MailSub = " Oil Service for your " & mySheet & " Machine"
 MailTxt = "Dear Sir," & vbLf & vbLf & "Please fine here with attached Training conducted details on for "
'Print '************************************************* ********
 
 'Turns off screen updating
 Application.ScreenUpdating = False
 
 'Makes a copy of the active sheet and save it to a temporary file
 Dim wks As Worksheet
 
 mySheet = Worksheets("Data").Cells(9, 2).Value
 TempFilePath = Environ$("temp") & ""
 TempFileName = mySheet & "Service details.pdf"
 FileFullPath = TempFilePath & TempFileName
 lCol = Cells(9, Columns.Count).End(xlToLeft).Column
 Set MR = Range("C9:N9" & lCol)
 For Each Cell In MR
 If Cell.Value > 25 And Cell.Value <= 50 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B2:F24").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 ElseIf Cell.Value > 400 And Cell.Value <= 500 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B26:F65").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 ElseIf Cell.Value > 900 And Cell.Value <= 1000 Then
 'Cell.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B67:F115").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 End If
 On Error GoTo 0
 Next Cell
  'Creates and shows the outlook mail item
 Set oApp = CreateObject("Outlook.Application")
 Set oMail = oApp.CreateItem(0)
 With oMail
 .To = MailTo
 .Subject = MailSub
 .Body = MailTxt
 .Attachments.Add FileFullPath
 .Display
 End With
Next Cnt
'Restores screen updating and release Outlook
 Application.ScreenUpdating = True
 Set oMail = Nothing
 Set oApp = Nothing
End Sub

---

Dear Dave,

How to chose email as per the row selected. The email address should not constant.

Code:

---

For Each c In rng.Cells
 s = s & c & ";"
 Next c
s = Left(s, Len(s) - 1)
 '--------------------End Email List-----------------------
 '************************************************* ********
 'Set email details; Comment out if not required
 MailTo = s

---

Seemed like U had made a long "s" string of mail recipients separated by semicolons... that was my psychic interpretation of your request. Where are the rows with addresses? Dave