Hi,
I currently have a raw data dump (5000+rows) in which I require to filter as per column D and then copy and paste results into new workbooks for each individual filter. I am trying to write a code which will auto filter and then post into a new work book.
Columns A through to F
Data starts at row 15
I currently have a raw data dump (5000+rows) in which I require to filter as per column D and then copy and paste results into new workbooks for each individual filter. I am trying to write a code which will auto filter and then post into a new work book.
Columns A through to F
Data starts at row 15
VBA Code:
Option Explicit
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
'Specify sheet name in which the data is stored
sht = "DATA Sheet"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
With Workbk.Sheets(sht)
Set rng = .Range("A15:F" & last)
End With
Workbk.Sheets(sht).Range("D1:D" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=4, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
Last edited by a moderator: