Filter Loop & Email

[Kelleeeeee]

I have a very long list of data, with a column named ‘requestor’. I need to create VBA to filter on the requestor, generate an email in outlook with the filtered table in the email body, input the email address and subject, and save it in drafts. Then repeat for each filter on my ‘requestor’ column.
Would this be possible?
Any help would be amazing!
Thanks

 

[paulxmw]

Hi has the requester got the same email address every time if so the following code may get you going, the email address goes in column A2 down as a list

Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim Ash As Worksheet
    Dim Cws As Worksheet
    Dim Rcount As Long
    Dim Rnum As Long
    Dim FilterRange As Range
    Dim FieldNum As Integer
    Dim Delay As String
    Dim sBody As String
    
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
     'Email message body
    StrBody = "some text here1"
              
    'Email Signature
    sBody = "some text here2"

    'Set filter sheet, you can also use Sheets("Email text")
    Set Ash = ActiveSheet

    'Set filter range and filter column (column with e-mail addresses)
    Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
    FieldNum = 2    'Filter column = B because the filter range start in column A

    'Add a worksheet for the unique list and copy the unique list in A1
    Set Cws = Worksheets.Add
    FilterRange.Columns(FieldNum).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=Cws.Range("A1"), _
            CriteriaRange:="", Unique:=True

    'Count of the unique values + the header cell
    Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

    'If there are unique values start the loop
    If Rcount >= 2 Then
        For Rnum = 2 To Rcount

            'Filter the FilterRange on the FieldNum column
            FilterRange.AutoFilter Field:=FieldNum, _
                                   Criteria1:=Cws.Cells(Rnum, 1).Value

              
              
            'If the unique value is a mail addres create a mail
            If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

                With Ash.AutoFilter.Range
                    On Error Resume Next
                    Set rng = .SpecialCells(xlCellTypeVisible)
                    On Error GoTo 0
                End With


' add delay time        hh:mm
Delay = Now + TimeValue("00:10")

                Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                With OutMail
                    .SentOnBehalfOfName = "central.payments@leeds.gov.uk"
                    .to = Cws.Cells(Rnum, 1).Value
                    .Subject = "Urgent action required - invoice in query"
                    .Body = StrBody & RangetoHTML(rng) & sBody 
                    .DeferredDeliveryTime = Delay
                    .Send  'Or use Send
                End With
                On Error GoTo 0

                Set OutMail = Nothing
            End If

            'Close AutoFilter
            Ash.AutoFilterMode = False
            

        Next Rnum
    End If

cleanup:
    Set OutApp = Nothing
    Application.DisplayAlerts = False
    Cws.Delete
    Application.DisplayAlerts = True

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
MsgBox ("All emails have now been sent")
End Sub

 

[Kelleeeeee]

Hey!

No, the requester each have different email addresses.
I have a code that splits all the information in to different tabs per requestor, and then i have the following which finds the email address related to each person and then attaches the file to it. Any idea how to get it to copy & paste the data rather than attaching it to the email?

Sub CommandButton1_Click()
     Dim Address As Variant
     Dim Dict As Object
     Dim DstWkb As Workbook
     Dim EmailInfo As Variant
     'Dim Filename As String
     Dim i As Long, j As Long
     Dim NewWkb As Workbook
     Dim olApp As Object
     Dim Rng As Range
     Dim SrcWkb As Workbook
     Dim SrcWks As Worksheet
     Dim SheetName As String
     Dim SheetNames As Variant

     ' Filename = ActiveWorkbook.FullName
     Set Rng = Range("A1").CurrentRegion
     ' EmailInfo starts in column "B" to the last column used.
     Set EmailInfo = Intersect(Rng, Rng.Offset(1, 0))
     ' Copy the sheet names and email addresses into arrays for faster processing.
     SheetNames = EmailInfo.Columns(1).Cells.Value
     EmailInfo = Intersect(EmailInfo, EmailInfo.Offset(0, 1)).Value
     ' Create an associative array to hold the email addresses and the sheet names for each one.
     Set Dict = CreateObject("Scripting.Dictionary")
     Dict.CompareMode = vbTextCompare
     
     ' Collect email addresses and sheet names associated with each address.
     For i = 1 To UBound(EmailInfo, 1)
          For j = 1 To UBound(EmailInfo, 2)
               SheetName = SheetNames(i, 1)
               Address = EmailInfo(i, j)
               If Address <> "" Then
                    If Not Dict.Exists(Address) Then
                         Dict.Add Address, SheetName
                    Else
                         SheetName = Dict(Address) & "," & SheetName
                         Dict(Address) = SheetName
                    End If
               End If
          Next j
     Next i
     ' Open the workbook with the sheets to be copied as email attachments.
     Set SrcWkb = ThisWorkbook
     Set olApp = CreateObject("Outlook.Application")
     For Each Address In Dict.Keys
          ' Create a new workbook to be used as the attachment with Sheet1, which is later deleted
          Set DstWkb = Workbooks.Add(xlWBATWorksheet)
          ' Copy all the sheets associated with an email to the new workbook.
          SheetNames = Split(Dict(Address), ",")
          For i = 0 To UBound(SheetNames, 1)
               SrcWkb.Worksheets(SheetNames(i)).Copy After:=DstWkb.Worksheets(DstWkb.Worksheets.Count)
               ActiveSheet.Name = SheetNames(i)
          Next i
          ' Turn off prompts
          Application.DisplayAlerts = False
          ' Delete Sheet1 so that workbook only contains sheets w scout information.
          Sheets("Sheet1").Delete
          ' Save the new workbook.
          DstWkb.SaveAs Filename:="Workbook2.xlsx"

          ' Turn prompts back on
          Application.DisplayAlerts = True
          
               ' Email Subject line.
      SubjectLine = "Test"
     ' Email Message.
     MsgBody = "Hello,"
     MsgBody = MsgBody & vbCrLf & vbCrLf
     MsgBody = MsgBody & "This is a test"
     MsgBody = MsgBody & vbCrLf
     MsgBody = MsgBody & "This is a test"
     MsgBody = MsgBody & vbCrLf
     MsgBody = MsgBody & "This is a test"
     MsgBody = MsgBody & vbCrLf & vbCrLf
     MsgBody = MsgBody & "This is a test"
     MsgBody = MsgBody & vbCrLf & vbCrLf
          ' Email the workbook as an attachment.
          With olApp.CreateItem(0)
               .To = Address
               .Subject = SubjectLine
               .Body = MsgBody
               .Attachments.Add DstWkb.FullName, 1, 1
               .Send
          End With
          ' Close the new workbook
          DstWkb.Close SaveChanges:=False
          ' Then delete it
          Kill "Workbook2.xlsx"
     Next Address
     ' Close the source workbook whose sheets were copied
     ' SrcWkb.Close SaveChanges:=False
End Sub