Sub FilterCopy()
Dim cl As Range
Dim Ws As Worksheet
Set Ws = Sheets("All Payments")
If Ws.FilterMode Then Ws.ShowAllData
With CreateObject("scripting.dictionary")
For Each cl In Ws.Range("B2", Ws.Range("B" & Rows.Count).End(xlUp))
If Not .Exists(cl.Value) Then
.Add cl.Value, Nothing
Ws.Copy
Range("A1").AutoFilter 2, "<>" & cl.Value
Range("B2:B5000").SpecialCells(xlVisible).EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.SaveAs "M:\all\FI Payments\Single Participant Payment Worksheets\Split Files" & cl.Value & ".xlsx", 51
ActiveWorkbook.Close False
End If
Next cl
End With
End Sub