VBA for making different files based on data en criteria group

[Faisel135]

This is what I want to do: I have a list with names (sheet mapping). Based on these names I want to filter 2 sheets ("Input AF" and "Input Sense") and delete all the not equal to that name. Then I want to save the file en go to next name on the list. See below my VBA. Hope someone can help. I'm out of options. Thnx!!

Option Explicit

Sub bestandmail()


Application.ScreenUpdating = False
Application.Calculation = xlManual

Worksheets(Array("Firstsheet", "Input Sense", "Input AF", "mapping")).Copy

Dim n As Long
Dim LastRowA As Long
LastRowA = Sheets("Input Sense").Cells(Rows.Count, 1).End(xlUp).Row



Sheets("Mapping").Select
Sheets("Mapping").Activate
Range("N1").Select
On Error Resume Next
n = 0
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(1, n).Select
n = n + 1


Sheets("Input Sense").Range("A1:P" & LastRowA).AutoFilter Field:=1, Criteria1:="<>" & ActiveCell
Sheets("Input Sense").AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
Sheets("Input Sense").AutoFilterMode = False
Sheets("Input Sense").Range("A:P").AutoFilter

Application.Goto Reference:=Worksheets("Input Sense").Range("A2"), scroll:=True

Sheets("Input AF").Range("A1:P" & LastRowA).AutoFilter Field:=1, Criteria1:="<>" & ActiveCell
Sheets("Input AF").AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
Sheets("Input AF").AutoFilterMode = False
Sheets("Input AF").Range("A:P").AutoFilter

Application.Goto Reference:=Worksheets("Input AF").Range("A2"), scroll:=True


Sheets("Input AF").Range("A2").Copy
Sheets("Firstsheet").Range("B2").PasteSpecial Paste:=xlPasteValues

Worksheets("Input Sense").Visible = False
Worksheets("Mapping").Visible = False

Application.Goto Reference:=Worksheets("Firstsheet").Range("A2"), scroll:=True
Application.Calculation = xlAutomatic


Dim Path As String
Dim filename As String
Path = "C:\temp\"
filename = Sheets("Firstsheet").Range("E2")
ActiveWorkbook.SaveAs filename:=Path & filename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close True
ActiveCell.Offset(0, 0).Select
Loop

Application.ScreenUpdating = True

End Sub

 

[Faisel135]

Anyone who can help?