Try
Sub test()
Dim a, i As Long, dic As Object
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
Sheets.Add Sheets(1)
With Sheets("blad1")
If .FilterMode Then .ShowAllData
.Cells.Copy Sheets(1).Cells(1)
With .Range("a6").CurrentRegion
a = .Columns("c").Value
For i = 2 To UBound(a, 1)
If Not dic.exists(a(i, 1)) Then
dic(a(i, 1)) = Empty
Sheets(1).Range("a6").CurrentRegion.Offset(1).ClearContents
.Parent.[e2].Formula = "=c7=" & Chr(34) & a(i, 1) & Chr(34)
.AdvancedFilter 2, .Parent.[e1:e2], Sheets(1).[a6].CurrentRegion
Sheets(1).Name = a(i, 1)
Sheets(1).Copy
With ActiveWorkbook
.SaveAs ThisWorkbook.Path & "\" & a(i, 1) & ".xlsx"
.Close False
End With
End If
Next
End With
.[e2].Clear
End With
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Bookmarks