VBA to send email of sheet within the new email

[keiranwyllie]

Hi folks,

I didn't want to hijack another thread so I'll start a new one here. When looking at this thread (https://www.mrexcel.com/forum/excel-questions/1102928-modifying-code-send-e-mail-3.html) I like the way the code creates a formatted email grabbing a range from a worksheet. In my case, I'd like to be able to achieve something similar with the following caveats:

• Group rows into a formatted email based on the same names in column A
• Create as many new emails as there are different names in Column A

I've been able to use the 'create pdf' code successfully but that still only captures all data in one file. It's not a show stopper however being able to create multiple emails means I can target specific people with email to only give me updates on the jobs they're currently working on (and not spam them with everyone else's jobs).

My worksheet (Report.xlsm) is located here - https://github.com/keiranwyllie/excel

This is the code that Worf provided in the above thread but I can't work out how to modify it to return the results I'm after.

[COLOR=#333333]Sub main2() ' run me[/COLOR]Dim a(1 To 2), i%, rng As Range, OutApp As Object, om As Object, r%, f$
lr = Range("e" & Rows.Count).End(xlUp).Row
Sort
a(1) = CDbl(Cells(2, 5))                ' day one
a(2) = CDbl(a(1) + 1)                   ' day two
For i = 1 To 2
    r = Evaluate("=sumproduct(max(row($e$2:$e$" & lr & ")*(" & a(i) & _
    "=$e$2:$e$" & lr & ")))") + 1
    Cells(r, 5).EntireRow.Insert
    Cells(r, 5).EntireRow.Clear
Next
Set rng = Range("d2:d" & lr + 2)
f = "=NÚM.CARACT(D2)>0"                     ' Portuguese version
'   f = "=len(d2)>0"                        ' use this one
rng.FormatConditions.Add Type:=xlExpression, Formula1:=f
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 6750207                        ' yellow
    .TintAndShade = 0
End With
rng.FormatConditions(1).StopIfTrue = 0
Set rng = Range("a1:f" & lr + 2)
Application.EnableEvents = 0
Set OutApp = CreateObject("Outlook.Application")
Set om = OutApp.CreateItem(0)
With om
    .To = "ron@debruin.nl"
    .CC = "carbon@copy.com"
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .display
End With
With Application
    .EnableEvents = True
    .ScreenUpdating = 1
End With
Set om = Nothing
Set OutApp = Nothing
[COLOR=#333333]End Sub
[/COLOR]

Any and all guidance will be greatly appreciated.

Regards.

 

[keiranwyllie]

Until I can work out the solution to my endeavor above, I'll be sticking with the 'create pdf' version that currently works for a single pdf. In an attempt to move forward and create separate pdfs based on the different values in column A, I've added this little but of handy code.

Sub LoopEachName()  
Dim aNames As Variant, Itm As Variant
  
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    aNames = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
    For Each Itm In aNames
      .AutoFilter Field:=1, Criteria1:=Itm
      
      'Do whatever you want with an individual name here
      
    Next Itm
    .AutoFilter
  End With 
End Sub

What I've noticed though is that it only works on a filtered list if the row numbers are consecutive. When there's a jump between rows to a different name, then the code just stops at the last consecutive row.

I can't attach my spreadsheets unfortunately at this stage so it's a bit difficult to show unless you're happy with grabbing it from my github upload. Unsure how else to do it.

 

[keiranwyllie]

I had success with the contiguous rows as mentioned above by using the following if anyone is interested.

  With Sheets("Job Tracking")  '<---Adjust        'Remove the Auto Filter
        .AutoFilterMode = False
 
        'Set the data range  <-- Adjust
        Set rngData = .Range("A2", Range("A" & Rows.Count).End(xlUp))
 
        'Apply the Auto filter to data range, criteria = "A*"  <-- Adjust
        rngData.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
 
        'Set the visible range
        With rngData
            Set rngVisible = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                  .SpecialCells(xlCellTypeVisible)
        End With
 
        'Loop through visible range and populate the array
        For Each rCell In rngVisible
            i = i + 1
            ReDim Preserve myArray(1 To i)
            myArray(i) = rCell
            rngData.AutoFilter Field:=1, Criteria1:=rCell

   ' Inserted my create pdf in email code

    Next rCell
      rngData.AutoFilter
  End With

I'm glad I was able to work through it and find a solution. Now on to the next challenge.

 

[Worf]

You could consider this code, which produces individual messages as shown:

Sub Macro1()
Dim lr%, i%, olapp As Object, myitem As MailItem
[i2] = [a2]
[i3] = "*"
Range("A2:A" & Range("a" & Rows.Count).End(xlUp).Row).AdvancedFilter _
xlFilterCopy, Range("I2:I3"), [n2], True
Set olapp = CreateObject("Outlook.Application")
For i = 3 To Range("n" & Rows.Count).End(xlUp).Row
    [i3] = Cells(i, "n")
    Range("a2").CurrentRegion.AdvancedFilter xlFilterCopy, [i2:i3], [p2], False
    ActiveSheet.ListObjects.Add(xlSrcRange, [p2].CurrentRegion, , xlYes).Name = "Table1"
    ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight21"
    Set myitem = olapp.CreateItem(olMailItem)
    With myitem
        .To = "sdaphne@fan.net"
        .Subject = "Jobs for " & [i3]
        .HtmlBody = RangetoHTML([p2].CurrentRegion)
        .Display
    End With
    [p:v].ClearContents
Next
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
    Dim fso As Object, ts As Object, TempFile$, 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
    '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=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[keiranwyllie]

Oh nice. I will definitely look at this...once I get outlook installed at home...or from work next week (I don't actually use Outlook at home lol). This is awesome though!!!!!