Sub FilterMacroToNewBooks()
Dim ws As Worksheet
Dim wb As Workbook
Dim rCellCounter As Range
Dim sDataSheet As String
Dim sCurrencyField As String
Dim iCurrencyColumn As Integer
sDataSheet = "Data" 'change this to the name of your sheet holding the original data
sCurrencyField = "Currency" 'change this to the title of your currency field
iCurrencyColumn = 1 'change this to the column number of your currency column
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
'Delete any existing currency sheets
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> sDataSheet Then ws.Delete
Next ws
Application.DisplayAlerts = True
'Create currency sheets
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = "Temp"
Sheets(sDataSheet).Columns(iCurrencyColumn).AdvancedFilter Action:=xlFilterCopy, _
criteriarange:="", copyToRange:=Sheets("Temp").Range("A1"), Unique:=True
'must include criteriarange - advanced filter "remembers" the last settings
'Filter on to each sheet
For Each rCellCounter In Sheets("Temp").Range("A1").CurrentRegion
If rCellCounter.Value <> sCurrencyField Then
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
ws.Name = rCellCounter.Value
ws.Range("a1").Value = sCurrencyField
ws.Range("a2").Value = rCellCounter.Value
Sheets(sDataSheet).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
criteriarange:=ws.Range("A1:A2"), copyToRange:=ws.Range("A4"), Unique:=False
ws.Rows("1:3").Delete
End If
Next rCellCounter
Application.DisplayAlerts = False
Sheets("Temp").Delete
Application.DisplayAlerts = True
For Each ws In Worksheets
If ws.Name <> sDataSheet Then ws.Move
Next ws
wb.Sheets(sDataSheet).Activate 'just for aesthetics
Application.ScreenUpdating = True
End Sub
)
