VBA for making different files based on data en criteria group

Faisel135

New Member
Joined
Sep 28, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.

Forum statistics

Threads
1,148,140
Messages
5,745,028
Members
423,917
Latest member
Frank1931

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top