Macro to produce e-mails based on values in cell

[sturnusek]

Hi all,

I have a table that is being filled out with risk orders that I have to e-mail to a customer so they can review it. There can be loads of them, so populating all can take a long time.

It has to be dependant on the region (F Column) and the Sold to (E Column), so if there are two orders in region 'Americas' and sold to is the same, I want it to copy the information about these orders (from column A to column G) and create a new e-mail template, preferably filling the subject as the Region & Sold to and send it to e-mail address in column G assigned to this order.

If there is two orders for Americas, but the Sold to value is different, I want it to populate two e-mails using the logic above, instead of one - preferably creating a loop until all is checked and populated without sending the actual e-mail, just creating a template to just validate the information and then click send.

There is multiple regions in the column, from Americas to Asia,

Does anyone has any ideas how to achieve this? I tried to look, but there has to be few checks and I am completely clueless how to even start writing a macro for this.

Appreciate your help

 

[Logit]

.
Please post a representative sample of your existing workbook with simulated data.

This forum does not allow for attachments ... you'll need to use a Cloud website like : DropBox.com , etc

 

[sturnusek]

Please see workbook in the link below, I have stripped it of all unnecessary data

https://www.dropbox.com/s/n8cncrryz7mzdbd/Risk Orders.xlsx?dl=0

 

[Logit]

.
Paste in Regular Module :

Option Explicit


Sub srtMe()
Dim LastRow As Long
    LastRow = Cells(Rows.Count, 7).End(xlUp).Row
    Range("A2:G" & LastRow).Sort Key1:=Range("G2:G" & LastRow), _
       Order1:=xlAscending, Header:=xlNo
    
    CreateSheets
    
End Sub


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


    Set RngBeg = Worksheets("Risk").Range("G2")
    Set RngEnd = Worksheets("Risk").Cells(Rows.Count, "G").End(xlUp)


Application.ScreenUpdating = False


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub


        For Each Cell In Worksheets("Risk").Range(RngBeg, RngEnd)
            On Error Resume Next
            
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)


                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                   
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
            
        Next Cell
        
Application.ScreenUpdating = True


MakeHeaders


End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Risk"
Application.ScreenUpdating = False


For dst = 3 To Sheets.Count
    If Sheets(dst).Name <> srcSheet And Sheets(dst).Name <> "Email" Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    Range("A1").EntireRow.Font.Bold = True
    Columns("A:G").EntireColumn.AutoFit
    Sheets(dst).Range("A1").Select
    End If
Next


Application.ScreenUpdating = True


CopyData


End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
On Error GoTo M
LastRow = Sheets("Risk").Cells(Rows.Count, "G").End(xlUp).Row
Dim ans As String
    
    For i = 2 To LastRow
    ans = Sheets("Risk").Cells(i, 7).Value
        Sheets("Risk").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans).Range("A1").EntireRow.Font.Bold = True
        Sheets(ans).Columns("A:G").EntireColumn.AutoFit
    Next
Sheets("Risk").Activate
Sheets("Risk").Range("A1").Select
Application.ScreenUpdating = True


CreateEmailList


Exit Sub


M:
MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True




End Sub


Sub CreateEmailList()
Dim wSheet As Worksheet
Dim n As Integer
Dim calcState As Long, scrUpdateState As Long


calcState = Application.Calculation
Application.Calculation = xlCalculationManual
scrUpdateState = Application.ScreenUpdating
Application.ScreenUpdating = False


n = 1


    With Sheet2
        .Cells(1, 1) = "Sheet Name"
        .Cells(1, 2) = "Email"
    End With
    Sheets("Email").Range("A2:B1000").Value = ""
    
    For Each wSheet In Worksheets
        If wSheet.Name <> "Email" And wSheet.Name <> "Risk" Then
            n = n + 1
            Sheet2.Cells(n, 1).Value = wSheet.Name
            Sheet2.Cells(n, 2).Value = wSheet.Name
        End If
    Next wSheet
    
Application.Calculation = calcState
Application.ScreenUpdating = scrUpdateState


SveShts


End Sub


Sub SveShts()


Dim xPath As String
Dim xWs As Worksheet


xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For Each xWs In ThisWorkbook.Sheets
    If xWs.Name <> "Risk" And xWs.Name <> "Email" Then
        xWs.Copy
        Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    End If
Next


Application.DisplayAlerts = True
Application.ScreenUpdating = True


SendEmail


End Sub
 
Sub SendEmail()


    Dim c As Range
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim i As Integer
    
    Dim xPath As String
    
    xPath = Application.ActiveWorkbook.Path
    Sheet2.Activate
    
        For Each c In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Cells
        
            Set OutLookApp = CreateObject("Outlook.application")
            Set OutLookMailItem = OutLookApp.CreateItem(0)
            
            With OutLookMailItem
                    .To = c.Value
                    .CC = "Your CC here"
                    .BCC = "test"
                    .Subject = "Your Subject here"
                    .HTMLBody = "Your Body content here"
                    .Attachments.Add xPath & "\" & c.Offset(0, -1).Value & ".xlsx"
                    'If you would like to auto-send emails .. comment out the next line and uncomment '.Send
                    .Display
                    '.Send
            End With
            
        Next c
Sheets("Risk").Activate
Sheets("Risk").Range("A1").Select
        
 
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/FXfcU4xQcLqZ4jTQXN2LvIUjQNgn1l2cd5VXql9ivoF

 

[sturnusek]

Thank you very much for your help, it's working absolutely fantastic.

Just a thought, instead of creating a separate excel file and attaching it, is it possible to just copy the separated selection to a body of the e-mail?

Thank you again.

 

[Logit]

.
Let me review your request .... give me some time.

 

[sturnusek]

Really appreciate your help on this.

 

[Logit]

.
This code is different from the first submission. For no particular reason I used two Regular Modules.
You can do the same or place all macros in a single Module.

Module #1 :

Option Explicit
Sub EmailRange()
Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strHtml As String
    Dim SendTo As String
    
    Set rng = Nothing
    On Error Resume Next
    
    SendTo = Worksheets("Email Range").Range("G2").Value
    Set rng = Worksheets("Email Range").Range("A1").CurrentRegion
    
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
        vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    
    'strHtml = "" & "******>" & "Hi All," & "
" & "
" & rng & "" & ""
    strHtml = "Please review data. " & "

" & _
                RangetoHTML(rng) & "

" & _
                "Regards," & "

" & _
                "Your Name Here 
"
         
    With OutMail
        .To = SendTo
        .CC = ""
        .Subject = "Sales Doc / Risk Data"
        .HTMLBody = strHtml '& RangetoHTML(rng)
        '.Send   'or use .Display
        .Display
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Worksheets("Email Range").Range("A1:G100").Value = ""
    
 
End Sub


Function RangetoHTML(rng As Range)
  
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
     'Copy the range and create a new workbook to past the data in
    rng.Copy
    
    Set TempWB = Workbooks.Add(1)
    
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
     'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
     'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")
    
     'Close TempWB
    TempWB.Close SaveChanges:=False
    
     'Delete the htm file we used in this function
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function


Sub SummarizeSheets()
Dim ws As Worksheet


For Each ws In Application.Worksheets
    If ws.Name <> "Risk" And ws.Name <> "Email Range" Then
        ws.Range("A1:G100").Copy Sheets("Email Range").Range("A1")  '<-- change range to copy/paste from each sheet here
        EmailRange
    End If
Next ws


End Sub

Module #2 :

Option Explicit


Sub srtMe()
Dim LastRow As Long
    LastRow = Cells(Rows.Count, 7).End(xlUp).Row
    Range("A2:G" & LastRow).Sort Key1:=Range("G2:G" & LastRow), _
       Order1:=xlAscending, Header:=xlNo
    
    CreateSheets
    
End Sub


Sub CreateSheets()


    Dim Cell    As Range
    Dim RngBeg  As Range
    Dim RngEnd  As Range
    Dim Wks     As Worksheet


    Set RngBeg = Worksheets("Risk").Range("G2")
    Set RngEnd = Worksheets("Risk").Cells(Rows.Count, "G").End(xlUp)


Application.ScreenUpdating = False


        ' Exit if the list is empty.
        If RngEnd.Row < RngBeg.Row Then Exit Sub


        For Each Cell In Worksheets("Risk").Range(RngBeg, RngEnd)
            On Error Resume Next
            
                ' No error means the worksheet exists.
                Set Wks = Worksheets(Cell.Value)


                ' Add a new worksheet and name it.
                If Err <> 0 Then
                    Set Wks = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                   
                    Wks.Name = Cell.Value
                End If
            On Error GoTo 0
            
        Next Cell
        
Application.ScreenUpdating = True


MakeHeaders


End Sub


Sub MakeHeaders()
Dim srcSheet As String
Dim dst As Integer
srcSheet = "Risk"
Application.ScreenUpdating = False


For dst = 3 To Sheets.Count
    If Sheets(dst).Name <> srcSheet And Sheets(dst).Name <> "Email" Then
    Sheets(srcSheet).Rows("1:1").Copy
    Sheets(dst).Activate
    Sheets(dst).Range("A1").PasteSpecial xlPasteValues
    Range("A1").EntireRow.Font.Bold = True
    Range("A1").EntireRow.Font.Color = vbWhite
    Range("A1:G1").Interior.ColorIndex = 23
    Columns("A:G").EntireColumn.AutoFit
    Sheets(dst).Range("A1").Select
    End If
Next


Application.ScreenUpdating = True


CopyData


End Sub


Sub CopyData()
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
'On Error GoTo M
LastRow = Sheets("Risk").Cells(Rows.Count, "G").End(xlUp).Row
Dim ans As String
    
    For i = 2 To LastRow
    ans = Sheets("Risk").Cells(i, 7).Value
        Sheets("Risk").Rows(i).Copy Sheets(ans).Rows(Sheets(ans).Cells(Rows.Count, "A").End(xlUp).Row + 1)
        Sheets(ans).Range("A1").EntireRow.Font.Bold = True
        Sheets(ans).Columns("A:G").EntireColumn.AutoFit
    Next
Sheets("Risk").Activate
Sheets("Risk").Range("A1").Select
Application.ScreenUpdating = True


SummarizeSheets


'Exit Sub


'M:
'MsgBox "No such sheet as  " & ans & " exist"
Application.ScreenUpdating = True




End Sub

Download workbook : https://www.amazon.com/clouddrive/share/KGaniUA9m8uDqPLKniepk8P0ETnWtr01vmWftNoqlzV

 

[sturnusek]

You are an absolute legend, thank you very much for your help. Much apprieciated!

 

[Logit]

.
Glad to help.