A Happy 20011 to one and all.
I was wondering if someone could assist me? I have cheekily copied someone's code to achieve what I want, however it doesn't quite do what I require. Basically I have a spreadsheet which I want only those rows which fall under a certain condition to be copied into a new sheet. For example if I have data populated in columns A, B & C, where C contains number reanging from 1 to 10; I would like to copy all data where the number in column C ranges from 3 and above. The code below copies everything that I need but I have to specify the number I want displayed. Is there a way (for example) I can amend the code to select all numbers greater than 3 and above? currently the code will display only those rows where column C is equal to 0?
I have attached my test spreadsheet for ease of understanding.
Apologies for any confision and thank you all in advance.
Cheers
Ivor
Sub Extract_Data_Two()
Application.ScreenUpdating = False
Dim FilterCriteria
Dim CurrentsheetName As String
Dim NewFileName As String
'Get the current sheets's name
CurrentsheetName = ActiveSheet.Name
'Select the range
'(note you can change this to meet your requirements)
Range("A1:C27").Select
'Apply Autofilter
Selection.AutoFilter
'Get the filter's criteria from the user
FilterCriteria = 2
'Filter the data based on the user's input
'NOTE - this filter is on column N (field:=14), to change
'to a different column you need to change the field number
Selection.AutoFilter field:=3, Criteria1:=FilterCriteria
'Select the visible cells (the filtered data)
Selection.SpecialCells(xlCellTypeVisible).Select
'Copy the cells
Selection.Copy
Sheets.Add
'Make sure you are in cell A1
Range("A1").Select
'Paste the copied cells
ActiveSheet.Paste
'Clear the clipboard contents
Application.CutCopyMode = False
' Auto fits text in Columns
Cells.Select
Selection.Columns.AutoFit
Range("A1").Select
'Go back to the original sheet
Worksheets(CurrentsheetName).Activate
'Clear the autofilter
Selection.AutoFilter field:=1
'Take the Autofilter off
Selection.AutoFilter
'Go to A1
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Bookmarks