Top 10 filter without using a Pivot Table

Question

Hello,

I have an inventory report that, among other info, it includes prices. I need a macro that gives me the top 10-15 most expensive parts and copy them over to another sheet. Here a sample of my report:

Material	Part Description	Plant	Stor. Location	On Hand	Cost	Total Cost ($)
material 1	description 1	plant 1	loc 1	1	$        <br>25.00	$        <br>25.00
material 2	description 2	plant 2	loc 2	2	$        <br>65.00	$      <br>130.00
material 3	description 3	plant 3	loc 3	3	$        <br>78.00	$      <br>234.00
material 4	description 4	plant 4	loc 4	4	$        <br>15.00	$        <br>60.00

Both sheets have the same format. I know that by using pivot tables I can get it but, I'd like to do it w/o a pt.

Thank you

Answer 1

Hi,

You can do this with auto filters.  Select the range and filter the total cost column on Number Filters > Top 10.

Hope this helps.

Answer 2

Hi,

try this..

Visible Cells top 10 Values

i assume that your data are on Sheet1 (in columns A:I)

and column Total Cost is column I (change as needed)

Extract data in a new Sheet

[Edit]

Sub AutoFilter10Max_CopyPaste()

Const rng As String = "A1:I" '<<< data in columns A:I changeConst myCol As String = "I" '<<< total cost changeDim ws As Worksheet

Set ws = Sheets("Sheet1") '<<< source sheet, changeDim r As Long

r = Cells(Rows.Count, myCol).End(xlUp).Row

Max1 = WorksheetFunction.Large(Range(myCol & "1:" & myCol & r), 1)

Max10 = WorksheetFunction.Large(Range(myCol & "1:" & myCol & r), 10) '<< change 10 to 15On Error Resume Next

ActiveSheet.AutoFilterMode = False

Range(myCol & "1:" & myCol & r - 1).AutoFilter , Field:=1, _

Criteria1:="<=" & Max1, Operator:=xlAnd, Criteria2:=">=" & Max10

Sheets.Add

ws.Range(rng & r).Copy

Range("A1").PasteSpecial xlPasteValues

Application.CutCopyMode = False

r = Cells(Rows.Count, myCol).End(xlUp).Row

Range(rng & r).Sort Key1:=Range(myCol & 1), Order1:=xlDescending, Header:=xlYes, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

ws.AutoFilterMode = False

On Error GoTo 0

End Sub