GENERATING AN EMAIL FOR EACH SHEET (insert sheet data between 2 sentences of email body)

[JuicyMusic]

Good Mooring,

I have been using a code that splits data from the "Source" tab into separate sheets. Each new sheet that is created ends up having the employee name as the sheet name - based on names in column A (starting at cell A3)

I need a code that will generate an email for each employee that has a new sheet. The number of new sheets will vary but never over 35 or so though, in case that is important.
The data from column A thru Z (thru to the last row of data) will need to be inserted in between the 4th and 5th sentence of a stock email from PR. I will provide the email template below. Every one will get the same wording.

The data set for each generated email should appear where I've indicated with a red rectangle on the 1st uploaded image. The user will be getting each employee's email address themselves.
the 2nd image is of the Source tab. I'm sorry that I can't upload this correctly. My company won't allow it.


"Source" tab specifics:
1) Row 1 has the report name and reporting month in cell A1 and B1
2) Row 2 has the headers - from column A thru Z
3) Column E & L & S & Z have no data in them. They are just highlighted black to visually separate 3 sections for data entry. For visual ease only.
4) Column G & I, and N & P, and U & W are hidden columns that contain helper formulas. They will always be hidden.
5) Each data set on each new tab has the exact number of columns - but the number of rows per new sheet WILL vary.

Thank you so much in advance,
Juicy

 

[mumps]

It looks like the best way to approach this is to insert the code that generates the emails into the macro you are currently using to create the new sheets. Can you post your current code? Please use code tags when posting the code.

 

[JuicyMusic]

Thank you Mumps. Here is the code. I hope I used the correct tag to wrap the code in.

Sub Split_Data_Into_Tabs()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        'Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
End Sub

 

[JuicyMusic]

It looks like the best way to approach this is to insert the code that generates the emails into the macro you are currently using to create the new sheets. Can you post your current code? Please use code tags when posting the code.

Mumps, Could the code retain the formatting of the Source tab too? We always have to resize the columns and rows after running the code that I have been using. Thank you so much.

 

[mumps]

Your code creates new sheets and moves existing sheets to the end. Do you want to create an email for only the newly created sheets but not for the existing sheets that are moved to the end?
Does this line of code not work to resize the columns?

Sheets(myarr(i) & "").Columns.AutoFit

Also, is there any reason why you are placing & "" at the end of the sheet name?

 

[JuicyMusic]

Yes, I only want to create an email for the newly created sheets. Not for the existing sheets.

The newly created sheets have the employee name and no "& "" appears in the new tab name. This is note something that I need. Thank you!!

 

[mumps]

Try:

Sub Split_Data_Into_Tabs()
    Dim lr As Long, ws As Worksheet, vcol, i As Integer, icol As Long, myarr As Variant, title As String, titlerow As Integer
    Dim OutApp As Object, OutMail As Object, rng As Range
    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 1
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next
    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear
    Set OutApp = CreateObject("Outlook.Application")
    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Set rng = Sheets(myarr(i) & "").UsedRange
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = ""
                .Subject = ""
                .HTMLBody = "You were at (percentage) for the month." & "<br><br>" & "Below is the Monthly Safety Compliance Breakdown " & _
                    "and your ISA's. Tailgate Meetings and COVID-19 checklists are attached with feedback for your review." _
                    & "<br><br>" & "Here is the feedabck on your monthly tailgates, ISA's and COVID-19 checklists:" & "<br><br>" _
                    & RangetoHTML(rng) & "<br><br>" & "Please let me know if you have any questions or concerns on any of this information."
                .Display
            End With
        Else
            Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        End If
        Sheets(myarr(i) & "").Columns.AutoFit
    Next i
    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
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"
    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
    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
    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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[JuicyMusic]

Good Morning Mumps, It ran perfectly. What a beautiful code and I am loving reading thru it.
It is so perfect that I hate asking one more thing. Is it possible for the formatting to transferred to the generated email as well? Thank you Thank you!

 

[mumps]

The code as written should be transferring the formatting as well as the data. Which formatting is not being transferred?

 

[JuicyMusic]

Mumps, All the formatting is being transferred except the 3 columns that are highlighted black. They are there to make have a break between the three sections. Visual ease.
Let me know if you think that those black column should be excluded from the transfer.

Here is an image of one of the generated emails. Thanks