This code allows to filter unique values in the column 1
next to save filtered data in the new excel file
plus 2 nd code to send filtered data via outlook
Sub filter()
Number = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.UsedRange.Sort Key1:=Range("A1:A" & Number), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Dim a() As Variant
Row1 = 1
ReDim Preserve a(row1)
Row1 = 0
Row = 2
For Row = 2 To Number
If Cells(Row - 1, 1) <> Cells(Row, 1) Then
a(Row1) = Cells(Row, 1)
Row1 = Row1 + 1
ReDim Preserve a(Row1)
Else
End If
Next Row
For i = 0 To UBound(a) - 1
ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:=a(i)
ActiveSheet.UsedRange.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Name = Cells(2, 1)
Path = "C:\programy\test\" 'you need to creat your own path
ActiveWorkbook.SaveAs Filename:=Path & Name
ActiveWindow.Close
Next i
Erase a
End Sub
PLUS: Sending via outlook filtered data
Sub filter()
Number = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.UsedRange.Sort Key1:=Range("A1:A" & Number), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Dim a() As Variant
Dim b() As Variant
Row1 = 1
ReDim Preserve a(Row1)
ReDim Preserve b(Row1)
Row1 = 0
Row = 2
For Row = 2 To Number
If Cells(Row - 1, 1) <> Cells(Row, 1) Then
a(Row1) = Cells(Row, 1)
b(Row1) = Cells(Row, 4)
Row1 = Row1 + 1
ReDim Preserve a(Row1)
ReDim Preserve b(Row1)
Else
End If
Next Row
For i = 0 To UBound(a) - 1
ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:=a(i)
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("C1:D" & LastRow).Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.UsedRange.Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = "Please read this email."
.Item.To = b(i)
.Item.Subject = "information"
.Item.Send
End With
ActiveWindow.Close False
Next i
Erase a
Erase b
End Sub