- Sub FilterAndSend()
- Dim wsData As Worksheet
- Dim wsRecipients As Worksheet
- Dim rngData As Range
- Dim rngCell As Range
- Dim filterValue As Variant
- Dim fileName As String
- Dim recipientRow As Long
- Dim outlookApp As Object
- Dim outlookMail As Object
- ' Set references to worksheets
- Set wsData = ThisWorkbook.Sheets("Tabelle1")
- Set wsRecipients = ThisWorkbook.Sheets("Recipients")
- ' Define the range of data
- Set rngData = wsData.Range("A1").CurrentRegion
- ' Loop through each unique value in column A and filter the data
- For Each rngCell In rngData.Columns(1).Offset(1).Resize(rngData.Rows.Count - 1).Cells
- filterValue = rngCell.Value
- ' Filter data based on the current value in column A
- rngData.AutoFilter Field:=1, Criteria1:=filterValue
- ' Define file name
- fileName = "FilteredData_" & filterValue & ".xlsx"
- ' Copy filtered data to a new workbook
- rngData.SpecialCells(xlCellTypeVisible).Copy
- ' Create a new workbook
- Dim newBook As Workbook
- Set newBook = Workbooks.Add
- ' Paste filtered data into new workbook
- newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
- ' Save new workbook with filtered data
- newBook.SaveAs fileName:=fileName
- ' Close new workbook
- newBook.Close
- ' Reset filter
- wsData.AutoFilterMode = False
- ' Get the row number of recipients for the current filter
- recipientRow = rngCell.Row
- ' Send email with attachment to recipients for the current filter
- SendEmail wsRecipients.Cells(recipientRow, 1).Value, fileName
- Next rngCell
- End Sub
- Sub SendEmail(recipient As String, attachmentPath As String)
- Dim outlookApp As Object
- Dim outlookMail As Object
- ' Create Outlook Application object
- Set outlookApp = CreateObject("Outlook.Application")
- ' Create new email
- Set outlookMail = outlookApp.CreateItem(0)
- ' Set email properties
- With outlookMail
- .To = recipient
- .Subject = "Filtered Data"
- .Body = "Please find the filtered data attached."
- .Attachments.Add attachmentPath
- .Send
- End With
- ' Clean up
- Set outlookMail = Nothing
- Set outlookApp = Nothing
- End Sub
[text] BUss
Viewer
Editor
You can edit this paste and save as new: