Consulting

Results 1 to 4 of 4

Thread: If condition for check all the rows

  1. #1
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    102
    Location

    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.

    Option Explicit
    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
    Attached Files Attached Files

  2. #2
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    668
    Location
    Seems like this should work. HTH. Dave
    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

  3. #3
    VBAX Contributor
    Joined
    Jun 2019
    Posts
    102
    Location
    Dear Dave,

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

  4. #4
    VBAX Expert Dave's Avatar
    Joined
    Mar 2005
    Posts
    668
    Location
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •