[text] BUss

Viewer

  1. Sub FilterAndSend()
  2.  
  3.     Dim wsData As Worksheet
  4.     Dim wsRecipients As Worksheet
  5.     Dim rngData As Range
  6.     Dim rngCell As Range
  7.     Dim filterValue As Variant
  8.     Dim fileName As String
  9.     Dim recipientRow As Long
  10.     Dim outlookApp As Object
  11.     Dim outlookMail As Object
  12.     
  13.     ' Set references to worksheets
  14.     Set wsData = ThisWorkbook.Sheets("Tabelle1")
  15.     Set wsRecipients = ThisWorkbook.Sheets("Recipients")
  16.     
  17.     ' Define the range of data
  18.     Set rngData = wsData.Range("A1").CurrentRegion
  19.     
  20.     ' Loop through each unique value in column A and filter the data
  21.     For Each rngCell In rngData.Columns(1).Offset(1).Resize(rngData.Rows.Count - 1).Cells
  22.         filterValue = rngCell.Value
  23.         
  24.         ' Filter data based on the current value in column A
  25.         rngData.AutoFilter Field:=1, Criteria1:=filterValue
  26.         
  27.         ' Define file name
  28.         fileName = "FilteredData_" & filterValue & ".xlsx"
  29.         
  30.         ' Copy filtered data to a new workbook
  31.         rngData.SpecialCells(xlCellTypeVisible).Copy
  32.         
  33.         ' Create a new workbook
  34.         Dim newBook As Workbook
  35.         Set newBook = Workbooks.Add
  36.         
  37.         ' Paste filtered data into new workbook
  38.         newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
  39.         
  40.         ' Save new workbook with filtered data
  41.         newBook.SaveAs fileName:=fileName
  42.         
  43.         ' Close new workbook
  44.         newBook.Close
  45.         
  46.         ' Reset filter
  47.         wsData.AutoFilterMode = False
  48.         
  49.         ' Get the row number of recipients for the current filter
  50.         recipientRow = rngCell.Row
  51.         
  52.         ' Send email with attachment to recipients for the current filter
  53.         SendEmail wsRecipients.Cells(recipientRow, 1).Value, fileName
  54.         
  55.     Next rngCell
  56.  
  57. End Sub
  58.  
  59. Sub SendEmail(recipient As String, attachmentPath As String)
  60.     Dim outlookApp As Object
  61.     Dim outlookMail As Object
  62.     
  63.     ' Create Outlook Application object
  64.     Set outlookApp = CreateObject("Outlook.Application")
  65.     
  66.     ' Create new email
  67.     Set outlookMail = outlookApp.CreateItem(0)
  68.     
  69.     ' Set email properties
  70.     With outlookMail
  71.         .To = recipient
  72.         .Subject = "Filtered Data"
  73.         .Body = "Please find the filtered data attached."
  74.         .Attachments.Add attachmentPath
  75.         .Send
  76.     End With
  77.     
  78.     ' Clean up
  79.     Set outlookMail = Nothing
  80.     Set outlookApp = Nothing
  81. End Sub
  82.  
  83.  

Editor

You can edit this paste and save as new:


File Description
  • BUss
  • Paste Code
  • 30 Apr-2024
  • 2.46 Kb
You can Share it: