Email with rows included in VBA with additional criteria

[peapop]

Hi everyone,

I am new here, just starting out with VBA and would like to get an advice from the experts here in this forum.

I am trying to manage stock inventory using excel sheet, which will be monitored by the "Alerting Limit" in column AF; "Safe" means our stock levels are good while "Critical" means we will need to purchase more of the stock.
What I would like to achieve is to be able to create a macro that can send an email(in outlook) for those stocks that are only listed as "CRITICAL" and send email to each unique email address in column C. As for those that have the same email address, additional rows are added to the same email draft in order to prevent sending 100 emails for 100 "critical" stock.

I have managed to generate the macro via referencing/copy-pasting from other posts but I am unable to pin-point what went wrong with the code. There are several rows that were added for "c@hotmail.com" even though the alerting limit was indicated as "SAFE". The only one that was correct was the "d@hotmail.com"(not shown below)

Heres my code

Sub Macro12()



    
'Set email address as range for first loop to run down
 Set Rng = Range(Range("J6"), Range("J" & Rows.Count).End(xlUp))

          
'Get a row count to clear column v at the end
  x = Rng.Rows.Count
 
'Create the html table and header from the first row
    tableHdr = "<table border=1><tr><th>" & Range("C5").Value & "</th>" _
            & "<th>" & Range("M5").Value & "</th>" _
            & "<th>" & "Quantity" & "</th>" _

'Check to see if column v = 'yes' and skip mail if it does
    For Each cell In Rng
    If ((cell.Value <> "") And (cell.Offset(0, 25).Value = "CRITICAL")) Then
    If Not cell.Offset(0, 23).Value = "Quotation Requested" Then

        
    NmeRow = cell.Row

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

    MailTo = cell.Value 'column J
    MailSubject = "Quotation Request"
    
'Create MailBody table row for first row
    MailBody = "<tr>" _
            & "<td>" & cell.Offset(0, -7).Value & "</td>" _
            & "<td>" & cell.Offset(0, 3).Value & "</td>" _
            & "</tr>"
            
           

'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the mailbody table
    For Each dwn In Rng.Offset(NmeRow, 0)
    
       


    If ((cell.Offset(0, 25).Value = "CRITICAL") And (dwn.Value = cell.Value)) Then
    
'Create additional table row for each extra row found"
    AddRow = "<tr>" _
            & "<td>" & dwn.Offset(0, -7).Value & "</td>" _
            & "<td>" & dwn.Offset(0, 3).Value & "</td>" _
            & "</tr>"
    


            
    dwn.Offset(0, 23).Value = "Quotation Requested"
    MailBody = MailBody & AddRow  'column A
    Else
    
    End If
' Clear additional table row variable ready for next
    AddRow = ""
    Next
        With OutMail
            .To = MailTo
            .Subject = MailSubject
            .HTMLBody = tableHdr & MailBody & "</table>"
            .Display
        'send
       End With
        
    cell.Offset(0, 23).Value = "Quotation Requested"
  
  End If
 End If
 
 
MailTo = ""
MailSubject = ""
MailBody = ""

'Clear 'Quotation Requested' from all appended cells in column v
 Range("Aj6:Aj" & x).ClearContents
 
 
 
 Next
End Sub

Appreciate your help!!

 

[sijpie]

Read all the comments in the code. Your code was a bit of a mess.

I am also rewriting the code completely, to make it much much faster. But check if this does away with the error and works OK.

Option Explicit

Sub Macro12()

' Original Macro re-organised with proper indentation, _
  declared variables, _
  updated comments, _
  added comments to point out ineffciencies (comments starting with >>>>).
  
' Corrected errors. See comments starting with !!!!

' >>>> The way the macro is written, looping through cells on the sheet a number of times is _
  very slow and inefficient. Either use arrays, or the Range.Find method
  
'!!!! ALWAYS declare your variables. Put 'Option Explicit' at the very top of the code module to force this.
'!!!! You had a variable named 'cell'. That is too much like the VBA object Cells. _
      I have renamed it rCell to indicate it is a Range variable
    Dim rEmailAddr As Range, rCell As Range, rNext As Range
    Dim lNmeRow As Long, lR As Long
    Dim MailTo As String, MailSubject As String, MailBody As String, sAddRow As String
    Dim OutApp As Object, OutMail As Object
    
    '>>>> !!!! Opening Outlook was done inside a loop, so it was opened many times (slow), whereas you only need to do it once.
    'Check if  Outlook already opened
    Set OutApp = GetObject(class:="Outlook.Application")
                      
    If OutApp Is Nothing Then
        'Outlook is not opened, so open
        Set OutApp = CreateObject("Outlook.Application")
    End If
    
    'Set email address as range for first loop to run down
    Set rEmailAddr = Range(Range("J6"), Range("J" & Rows.Count).End(xlUp))

    ' >>>> MailSubject does not change, so only needs to be created once, outside loop
    MailSubject = "Quotation Request"
          
    'Get a row count to clear column AF at the end
    lR = rEmailAddr.Rows.Count
 
    'Create the html table and header from the first row
    tableHdr = "<table border=1><tr><th>" & Range("C5").Value & "</th>" _
            & "<th>" & Range("M5").Value & "</th>" _
            & "<th>" & "Quantity" & "</th>" _

    'Check to see if column AF = 'SAFE' and skip mail if it does
    For Each rCell In rEmailAddr
        '!!!! Column AF holds SAFE/CRITICAL has offset 22 (not 25) _
              It is really also better to calculate the offset, in case you move columns about or add columns later.( Not done here)
              
'        If ((rCell.Value <> "") And (rCell.Offset(0, 25).Value = "CRITICAL")) Then
'            If Not rCell.Offset(0, 23).Value = "Quotation Requested" Then

        '>>>> Why use long string "Quotation Requested" as a temporary flag. Just TRUE will do. Is easier to process.
        
        If ((rCell.Value <> "") And (rCell.Offset(0, 22).Value = "CRITICAL")) Then
            If Not rCell.Offset(0, 23).Value = True Then    'True is flag in column AG to indicate item already processed
                lNmeRow = rCell.Row
            
                MailTo = rCell.Value 'column J
                
                'Create MailBody table row for first row
                MailBody = "<tr>" _
                        & "<td>" & rCell.Offset(0, -7).Value & "</td>" _
                        & "<td>" & rCell.Offset(0, 3).Value & "</td>" _
                        & "</tr>"
                        
                       
            
                'Second loop checks the email addresses of all cells following the current cell in the first loop.
                'Yes will be appended on any duplicate finds and another row added to the mailbody table
                
                '>>>> Your loop would run for the sam number of rows everytime, so if your database is 1000 rows, _
                      then if it were to process the last row in the database, it would run through 999 empty rows. Very, very inefficient.
                'For Each rNext In rEmailAddr.Offset(lNmeRow, 0)
                
                For Each rNext In rEmailAddr.Offset(lNmeRow, 0).Resize(lR - lNmeRow)    'process to last row only
                    If ((rCell.Offset(0, 22).Value = "CRITICAL") And (rNext.Value = rCell.Value)) Then
                    
                        'Create additional table row for each extra row found"
                        sAddRow = "<tr>" _
                                & "<td>" & rNext.Offset(0, -7).Value & "</td>" _
                                & "<td>" & rNext.Offset(0, 3).Value & "</td>" _
                                & "</tr>"
                        
                    
                    
                                
                        rNext.Offset(0, 23).Value = True
                        MailBody = MailBody & sAddRow  '
                    
                    End If
                    '>>>> Don't need to clear. sAddRow will be reset anyway
'                    ' Clear additional table row variable ready for next
'                    sAddRow = ""
                Next rNext
                
                ' Now create email
                Set OutMail = OutApp.createitem(0)
                With OutMail
                     .to = MailTo
                     .Subject = MailSubject
                     .HTMLBody = tableHdr & MailBody & "</table>"
                     .Display
                 'send
                End With
                    
                rCell.Offset(0, 23).Value = True
                        
            End If
        End If
         
         '>>>> No need to do this. The less you do inside a loop the better
'        MailTo = ""
'        MailSubject = ""
'        MailBody = ""
        
        'Clear 'Quotation Requested' from all appended cells in column AJ
         'Range("AJ6:AJ" & lR).ClearContents '!!!!
         Range("AG6:AG" & lR).ClearContents '!!!! You were clearing column AJ, not AG
 
    Next rCell
End Sub

 

[peapop]

Hi sijpie,

Thanks a lot for looking. I had ran the code that you had posted and it has generated 2 emails like this;

while the excel sheet;

Still trying to digest the comments that you wrote one by one; appreciate your help in this

 

[sijpie]

I'll get you a very different version later today

 

[sijpie]

Here is the code that will work vary fast even on huge databases. It copies the database to an array, and then uses the array for all the checking and data to be filled out. It also doesn't write anything to the worksheet. Writing and reading are relatively slow processes. This code uses only one read!

Option Explicit

Sub OrderCritical()     'Give your macro a meaningful name

' Macro to request quotes for all critical stock
 
    Dim vInput As Variant
    Dim lNmeRow As Long, lR As Long, UB1 As Long, UB2 As Long, lName As Long, _
        lEmailAdr As Long, lCatNr As Long, lAlert As Long, lQR As Long, lHeadrRow As Long, lC As Long
    Dim MailTo As String, MailSubject As String, MailBody As String, sAddRow As String, sHead As String, _
        sTableHdr As String
    Dim OutApp As Object, OutMail As Object
   
   
    'Check if  Outlook already opened
    Set OutApp = GetObject(class:="Outlook.Application")

    If OutApp Is Nothing Then
        'Outlook is not opened, so open
        Set OutApp = CreateObject("Outlook.Application")
    End If
   
    'find header row
    lHeadrRow = Range("C:C").Find("Name").Row
    'Put database into array
    vInput = Range("C" & lHeadrRow).CurrentRegion.Value
   
    'number of rows in database:
    UB1 = UBound(vInput, 1)
    'number of columns in database:
    UB2 = UBound(vInput, 2)
   
    'Find columns to be used
    For lC = 1 To UB2
        sHead = vInput(1, lC)
        Select Case True
            Case sHead Like "Name*"
                lName = lC
            Case sHead Like "*Vendor*"
                lEmailAdr = lC
            Case sHead Like "Catalo*"
                lCatNr = lC
            Case sHead Like "Alert*"
                lAlert = lC
            Case sHead Like "Quotat*"
                lQR = lC
               
        End Select
    Next lC

    ' >>>> MailSubject does not change, so only needs to be created once, outside loop
    MailSubject = "Quotation Request"
         
 
    'Create the html table and header from the first row
    sTableHdr = "<table border=1><tr><th>" & vInput(1, lName) & "</th>" _
            & "<th>" & vInput(1, lCatNr) & "</th>" _
            & "<th>" & "Quantity" & "</th>" _

    'Check to see if column lAlert (AF) = 'SAFE' and skip mail if it does
    For lR = 2 To UB1
       
        If vInput(lR, lAlert) Like "CRITICAL" And Not vInput(lR, lQR) = True Then    'True is flag to indicate item already processed
           
            MailTo = vInput(lR, lEmailAdr)
           
            'Create MailBody table row for first row
            MailBody = "<tr>" _
                    & "<td>" & vInput(lR, lName) & "</td>" _
                    & "<td>" & vInput(lR, lCatNr) & "</td>" _
                    & "</tr>"
            'set flag that line is processed
            vInput(lR, lQR) = True
       
            'Second loop checks all critical items from the same vendor.
            For lC = lR + 1 To UB1
               
                If MailTo Like vInput(lC, lEmailAdr) And vInput(lC, lAlert) Like "CRITICAL" Then
                       
                    'Create additional table row for each extra row found"
                    sAddRow = "<tr>" _
                            & "<td>" & vInput(lC, lName) & "</td>" _
                            & "<td>" & vInput(lC, lCatNr) & "</td>" _
                            & "</tr>"
                   
                    MailBody = MailBody & sAddRow  '
                       
                    vInput(lC, lQR) = True
                       
                End If
            Next lC
           
            ' Now create email
            Set OutMail = OutApp.createitem(0)
            With OutMail
                 .To = MailTo
                 .Subject = MailSubject
                 .HTMLBody = sTableHdr & MailBody & "</table>"
                 .Display
             'send
            End With
                       
        End If
    Next lR
   
End Sub

 

[sijpie]

By the way, in the first macro (the inefficient one) I had the clear column AJ line before the end of the loop, that should have been the very last line:

(Don't use this code, use the code in the post above! This is just to correct the error in the first macro)

Sub Macro12()

' Original Macro re-organised with proper indentation, _
  declared variables, _
  updated comments, _
  added comments to point out ineffciencies (comments starting with >>>>).
 
' Corrected errors. See comments starting with !!!!

' >>>> The way the macro is written, looping through cells on the sheet a number of times is _
  very slow and inefficient. Either use arrays, or the Range.Find method
 
'!!!! ALWAYS declare your variables. Put 'Option Explicit' at the very top of the code module to force this.
'!!!! You had a variable named 'cell'. That is too much like the VBA object Cells. _
      I have renamed it rCell to indicate it is a Range variable
    Dim rEmailAddr As Range, rCell As Range, rNext As Range
    Dim lNmeRow As Long, lR As Long
    Dim MailTo As String, MailSubject As String, MailBody As String, sAddRow As String
    Dim OutApp As Object, OutMail As Object
   
    '>>>> !!!! Opening Outlook was done inside a loop, so it was opened many times (slow), whereas you only need to do it once.
    'Check if  Outlook already opened
    Set OutApp = GetObject(class:="Outlook.Application")
                     
    If OutApp Is Nothing Then
        'Outlook is not opened, so open
        Set OutApp = CreateObject("Outlook.Application")
    End If
   
    'Set email address as range for first loop to run down
    Set rEmailAddr = Range(Range("J6"), Range("J" & Rows.Count).End(xlUp))

    ' >>>> MailSubject does not change, so only needs to be created once, outside loop
    MailSubject = "Quotation Request"
         
    'Get a row count to clear column AF at the end
    lR = rEmailAddr.Rows.Count
 
    'Create the html table and header from the first row
    tableHdr = "<table border=1><tr><th>" & Range("C5").Value & "</th>" _
            & "<th>" & Range("M5").Value & "</th>" _
            & "<th>" & "Quantity" & "</th>" _

    'Check to see if column AF = 'SAFE' and skip mail if it does
    For Each rCell In rEmailAddr
        '!!!! Column AF holds SAFE/CRITICAL has offset 22 (not 25) _
              It is really also better to calculate the offset, in case you move columns about or add columns later.( Not done here)
             
'        If ((rCell.Value <> "") And (rCell.Offset(0, 25).Value = "CRITICAL")) Then
'            If Not rCell.Offset(0, 23).Value = "Quotation Requested" Then

        '>>>> Why use long string "Quotation Requested" as a temporary flag. Just TRUE will do. Is easier to process.
       
        If ((rCell.Value <> "") And (rCell.Offset(0, 22).Value = "CRITICAL")) Then
            If Not rCell.Offset(0, 23).Value = True Then    'True is flag in column AG to indicate item already processed
                lNmeRow = rCell.Row
           
                MailTo = rCell.Value 'column J
               
                'Create MailBody table row for first row
                MailBody = "<tr>" _
                        & "<td>" & rCell.Offset(0, -7).Value & "</td>" _
                        & "<td>" & rCell.Offset(0, 3).Value & "</td>" _
                        & "</tr>"
                       
                      
           
                'Second loop checks the email addresses of all cells following the current cell in the first loop.
                'Yes will be appended on any duplicate finds and another row added to the mailbody table
               
                '>>>> Your loop would run for the sam number of rows everytime, so if your database is 1000 rows, _
                      then if it were to process the last row in the database, it would run through 999 empty rows. Very, very inefficient.
                'For Each rNext In rEmailAddr.Offset(lNmeRow, 0)
               
                For Each rNext In rEmailAddr.Offset(lNmeRow, 0).Resize(lR - lNmeRow)    'process to last row only
                    If ((rCell.Offset(0, 22).Value = "CRITICAL") And (rNext.Value = rCell.Value)) Then
                   
                        'Create additional table row for each extra row found"
                        sAddRow = "<tr>" _
                                & "<td>" & rNext.Offset(0, -7).Value & "</td>" _
                                & "<td>" & rNext.Offset(0, 3).Value & "</td>" _
                                & "</tr>"
                       
                   
                   
                               
                        rNext.Offset(0, 23).Value = True
                        MailBody = MailBody & sAddRow  '
                   
                    End If
                    '>>>> Don't need to clear. sAddRow will be reset anyway
'                    ' Clear additional table row variable ready for next
'                    sAddRow = ""
                Next rNext
               
                ' Now create email
                Set OutMail = OutApp.createitem(0)
                With OutMail
                     .To = MailTo
                     .Subject = MailSubject
                     .HTMLBody = tableHdr & MailBody & "</table>"
                     .Display
                 'send
                End With
                   
                rCell.Offset(0, 23).Value = True
                       
            End If
        End If
        
         '>>>> No need to do this. The less you do inside a loop the better
'        MailTo = ""
'        MailSubject = ""
'        MailBody = ""
       
    Next rCell
   
    'Clear 'Quotation Requested' from all appended cells in column AJ
     'Range("AJ6:AJ" & lR).ClearContents '!!!!
     Range("AG6:AG" & lR).ClearContents '!!!! You were clearing column AJ, not AG
 
End Sub

 

[peapop]

Hello sijpie,

Thank you so much for the help! The code worked!

I have another question; if I had to write "True" (in the AG column) on those that I had already generated the emails for (in order to prevent double purchases), how should I go about it?

 

[sijpie]

you mean to say that after the macro has run then column AG contains True for each line processed?

 

[peapop]

Yes, that is correct.

Also when the macro run the 2nd time, the lines which already contains "True" are skipped and will not be added as rows in the email

 

[peapop]

Yes, that is correct.

Also when the macro run the 2nd time, the lines which already contains "True" are skipped and will not be added as rows in the email

which will act like a filter so that we wont purchase the same thing twice