Solved: Find top ten values for each category

[jazznaura]

Hi all,
I need help filtering a list by category, then find the top ten values, and copy them to tables on a summary sheet. I can?t use the excel filter as it won?t let me filter by category AND use the top ten filter. I can use a loop the go through the list to find the category but I don?t know how to code to retrieve the ten top values.
Can someone help with a snippet of code or a point in the right direction?
I?ve attached my workbook to help explain.
Thank you,
Jazz Naura

[mikerickson]

You can do this with Advanced Filter.
First create two Names

Name: dataRange
RefersTo: =OFFSET('IR19'!$A$1,1,0,COUNTA('IR19'!$A:$A),5)
(That is a dynamic named range of your data without headers)

Name: FilteredVals
RefersTo:=LARGE(INDEX(dataRange,,3)*(INDEX(dataRange,,5)='IR19'!$I$2),ROW(' IR19'!$A$1:$A$10))
Which is the top ten values from column C (value) of those rows where column E(category) matches what is in $I$2

Then a two row, two column Criteria Range in I1:J2 will filter as you want.
I1 holds "category" (no quotes)
J1 is blank
I2 holds the category you want
J2 holds =ISNUMBER(MATCH((E2=$I$2)*C2,top10FilteredVals,0))

AdvanceFilter with I1:J2 as the criteria Range and you will see the top ten Values of the category in I2.
See attached

[MaximS]

Check my macro in atttached file. That should solve your problem.

[jazznaura]

thanks guys for your replies.

mikerickson, your solution is beyond my current knowledge, but will have a look at it and hopefully learn something new.

MaximS, the macros great, just what i was wanting to do, thanks.

[mikerickson]

The use of custom formulas in Advanced Filter criteria is the key. The names are just for clarity in a convoluted array formula.

[rajkumar]

Hi Maxim,
Your code is really superb. Now i tried to append it to one of my macro,
i'm getting an error Sub or function not defined.

I have posted my code herewith. Could you help me to make use of it.:dunno



Sub CORREPORT()

fName = Dir("C:\Data_Analysis\COR\COR-*.TXT")
Dim t As Date
'set a variable equal to the starting time
t = Now()

If Not FileFolderExists("C:\Data_Analysis\COR\COR-*.TXT") Then
MsgBox "Text file for this report is not present. Hence Ending Report"
Exit Sub
Else

If fName <> "" Then
Do
Application.ScreenUpdating = False

Call PGMTR
Workbooks.OpenText FileName:="C:\Data_Analysis\COR\" & fName, Origin:=437, StartRow:=1, _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(8, 1), Array(28, 1), _
Array(57, 1), Array(63, 1), Array(69, 1), Array(78, 1), Array(89, 1), Array(102, 1), Array( _
105, 1), Array(117, 1), Array(131, 1), Array(157, 1), Array(166, 1)), _
TrailingMinusNumbers:=True
Call DELCOR1(fName)

fName = Dir()
Loop Until fName = ""
End If
End If
Application.ScreenUpdating = True

MsgBox ("COR Report is Completed in ") & Format(Now() - t, "hh:mm:ss") & (" (HH:MM:SS)")

End Sub
Sub DELCOR1(ByVal fName As String)
Dim DelRange As Range
Dim c As Range
For Each c In ActiveSheet.Range("A:A").Cells
If c.Value = "Xerox In" Then
If DelRange Is Nothing Then
Set DelRange = c.EntireRow
Else
Set DelRange = Union(DelRange, c.EntireRow)
End If
End If
Next c
'turn on error handling in case no range is assigned
On Error Resume Next
DelRange.Delete
On Error GoTo 0
Call DELCOR2(fName)
End Sub

Sub DELCOR2(ByVal fName As String)
'turn On Error handling in case no matching cells
On Error Resume Next
Range("A:A").AutoFilter Field:=1, Criteria1:="*--*"
If Err = 0 Then _
Range("A:A").SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
ActiveSheet.AutoFilterMode = False
ActiveSheet.UsedRange
'turn off error handling
On Error GoTo 0
Call delcor3(fName)
End Sub
Sub delcor3(ByVal fName As String)
On Error Resume Next
Range("A:A").AutoFilter Field:=1, Criteria1:="**"
If Err = 0 Then _
Range("A:A").SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
ActiveSheet.AutoFilterMode = False
ActiveSheet.UsedRange
'turn off error handling
On Error GoTo 0
Call delcor4(fName)
End Sub
Sub delcor4(ByVal fName As String)
On Error Resume Next
Range("A:A").AutoFilter Field:=1, Criteria1:="*Engno*"
If Err = 0 Then _
Range("A:A").SpecialCells(xlCellTypeVisible) _
.EntireRow.Delete
ActiveSheet.AutoFilterMode = False
ActiveSheet.UsedRange
'turn off error handling
On Error GoTo 0
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

Call DeleteCertainRows(fName)
End Sub
Sub DeleteCertainRows(ByVal fName As String)

Dim TestRange As Range

Dim LastRow As Long, firstRow As Long

Dim i As Long

'restrict the range to be tested to just cells in column A that are

'in the active sheet's used range

Set TestRange = Intersect(Range("A:A"), ActiveSheet.UsedRange)

'get last row number in the range

LastRow = TestRange.Cells(TestRange.Cells.Count).Row

'get the first row number in the range

firstRow = TestRange.Cells(1).Row

'cycle through the rows from last to first - this is done in case

'a row is delete

For i = LastRow To firstRow Step -1

'before testing the value of the cell, make certain it is a

'numeric cell. Otherwise an error will occur

If Cells(i, 1).Value = "" Then

'if the value in column A (column 1) is blank, delete the row

Rows(i).Delete

End If

Next
Call HEADINGCOR(fName)
End Sub
Sub HEADINGCOR(ByVal fName As String)
Rows("1:1").Select
Application.CutCopyMode = False
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "ENGR NO"
Range("B1").FormulaR1C1 = "Part No"
Range("C1").FormulaR1C1 = "Description"
Range("D1").FormulaR1C1 = "Qty"
Range("E1").FormulaR1C1 = "Cls"
Range("F1").FormulaR1C1 = "Cost"
Range("G1").FormulaR1C1 = "Serv Req No"
Range("H1").FormulaR1C1 = "Call Type"
Range("I1").FormulaR1C1 = "STS"
Range("J1").FormulaR1C1 = "Model"
Range("K1").FormulaR1C1 = "Mc Sr. No"
Range("L1").FormulaR1C1 = "Customer Name"
Range("M1").FormulaR1C1 = "Mcln"
Range("N1").FormulaR1C1 = "Usage Dt"
Call FRAMEcor5(fName)
End Sub

Sub FRAMEcor5(ByVal fName As String)

Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFormat Format:=xlRangeAutoFormatList3, Number:=True, Font:= _
True, Alignment:=True, Border:=True, Pattern:=True, Width:=True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Call formatcor(fName)
End Sub
Sub formatcor(ByVal fName As String)
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Columns("R:R").Select
Selection.Copy
Columns("B:H").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Patch"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Group"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Model"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Customer"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Cust no"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Family"
Cells.Select
Cells.EntireColumn.AutoFit
ChDir "C:\Data_Analysis"
Workbooks.Open FileName:="C:\Data_Analysis\Reference Table.xls", Origin:= _
xlWindows
Windows(fName).Activate
Call PATCHCOR(fName)
End Sub
Sub PATCHCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long

sSheetName = Left(fName, Len(fName) - 4)

lastRw = Worksheets(sSheetName).Range("C2").End(xlDown).Row

With Worksheets(sSheetName).Range("C2")

.Formula = "=VLOOKUP(RC[-1],'Reference Table.xls'!MIF_BASE,3,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("C2:C" & lastRw&)

End With
Call GROUPCOR(fName)
End Sub
Sub GROUPCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("D2").End(xlDown).Row

With Worksheets(sSheetName).Range("D2")

.Formula = "=VLOOKUP(RC[-2],'Reference Table.xls'!MIF_BASE,4,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("D2:D" & lastRw&)

End With
Call MODELCOR(fName)
End Sub
Sub MODELCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("E2").End(xlDown).Row

With Worksheets(sSheetName).Range("E2")

.Formula = "=VLOOKUP(RC[-3],'Reference Table.xls'!MIF_BASE,5,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("E2:E" & lastRw&)

End With
Call CUSTOMERCOR(fName)
End Sub
Sub CUSTOMERCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("F2").End(xlDown).Row

With Worksheets(sSheetName).Range("F2")

.Formula = "=VLOOKUP(RC[-4],'Reference Table.xls'!MIF_BASE,6,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("F2:F" & lastRw&)

End With
Call ACCOUNTCOR(fName)
End Sub
Sub ACCOUNTCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("G2").End(xlDown).Row

With Worksheets(sSheetName).Range("G2")

.Formula = "=VLOOKUP(RC[-5],'Reference Table.xls'!MIF_BASE,7,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("G2:G" & lastRw&)

End With
Call FAMILYCOR(fName)
End Sub
Sub FAMILYCOR(ByVal fName As String)

Dim myRng As Range

Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("H2").End(xlDown).Row

With Worksheets(sSheetName).Range("H2")

.Formula = "=VLOOKUP(RC[-6],'Reference Table.xls'!MIF_BASE,8,0)"

.AutoFill Destination:=Worksheets(sSheetName).Range("H2:H" & lastRw&)

End With
Call INSERTEDCOR(fName)
End Sub
Sub INSERTEDCOR(ByVal fName As String)
Range("C:H").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Delete
Windows("Reference Table.xls").Close
Cells.Select
Cells.EntireColumn.AutoFit
Columns("H:H").Select
Call PARTDESC
Columns("U:U").Delete
Call MAPPING(fName)
End Sub
Sub MAPPING(ByVal fName As String)
Columns("P:P").Select
Call PRDCTFAM
Range("W1").Select
ActiveCell.FormulaR1C1 = "MAPPING"
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
Range("A1").Select
Columns("V:V").Delete
Call WKWISECOR(fName)
End Sub
Sub WKWISECOR(ByVal fName As String)
Columns("Q:Q").Select
Selection.Copy
Columns("W:W").Select
ActiveSheet.Paste
Range("W1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "WEEK NO"
Range("W2").Select
ChDir "C:\Data_Analysis"
Workbooks.Open FileName:="C:\Data_Analysis\Reference Table.xls", Origin:= _
xlWindows
Windows(fName).Activate
Call FORWKCOR(fName)
End Sub
Sub FORWKCOR(ByVal fName As String)

Dim myRng As Range
Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("W2").End(xlDown).Row
With Worksheets(sSheetName).Range("W2")
.Formula = "=VLOOKUP(RC[-3],'[Reference Table.xls]wk day'!R2C1:R367C5,3,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("W2:W" & lastRw&)
End With
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
Columns("W:W").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

Call FORMNTH(fName)
End Sub
Sub FORMNTH(ByVal fName As String)
Columns("W:W").Select
Selection.Copy
Columns("X:X").Select
ActiveSheet.Paste
Range("X1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "MONTH"
Dim myRng As Range
Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("X2").End(xlDown).Row
With Worksheets(sSheetName).Range("X2")
.Formula = "=VLOOKUP(MONTH(RC[-4]),'Reference Table.xls'!MONTHNO,2,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("X2:X" & lastRw&)
End With
Columns("X:X").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit

Range("A1").Select
Call tonerspare(fName)
End Sub
Sub tonerspare(ByVal fName As String)
Columns("A:A").Select
Selection.Copy
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Toner /Spares"
Range("B2").Select
Dim myRng As Range
Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("B2").End(xlDown).Row
With Worksheets(sSheetName).Range("B2")
.Formula = "=IF(RC[-1]=0,""Toner"",""Spares"")"
.AutoFill Destination:=Worksheets(sSheetName).Range("B2:B" & lastRw&)
End With
Columns("B:B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit
Call QTRANDHALFYEAR(fName)
End Sub
Sub QTRANDHALFYEAR(ByVal fName As String)
Columns("Y:Y").Select
Selection.Copy
Columns("Z:AA").Select
ActiveSheet.Paste
Range("Z1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "QTR"
Range("AA1").Select
ActiveCell.FormulaR1C1 = "HALF YEAR"
Range("Z2").Select

Dim myRng As Range
Dim lastRw As Long
sSheetName = Left(fName, Len(fName) - 4)
lastRw = Worksheets(sSheetName).Range("Z2").End(xlDown).Row
With Worksheets(sSheetName).Range("Z2")
.Formula = "=VLOOKUP(RC[-5],'Reference Table.xls'!WEEKNO,6,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("Z2:Z" & lastRw&)
End With
lastRw = Worksheets(sSheetName).Range("AA2").End(xlDown).Row
With Worksheets(sSheetName).Range("AA2")
.Formula = "=VLOOKUP(RC[-6],'Reference Table.xls'!WEEKNO,7,0)"
.AutoFill Destination:=Worksheets(sSheetName).Range("AA2:AA" & lastRw&)
End With

Cells.Select
Cells.EntireColumn.AutoFit
Columns("Z:AA").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Windows("Reference Table.xls").Close
Call TopTen(fName)
End Sub
Sub TopTen(ByVal fName As String)

Sheets.Add Type:="Worksheet"
With ActiveSheet
.Move After:=Worksheets(Worksheets.Count)
.Name = "Top 10 Patch wise"
End With
Range("A1").Select

Sheets(Left(fName, Len(fName) - 4)).Select

Dim f, LastRow As Long

f = 1

LastRow = Range("A65536").End(xlUp).Row

Range("A1:AA" & LastRow).Select
Selection.Sort Key1:=Range("M2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Dim Category As Variant

Set Range1 = Sheets(Left(fName, Len(fName) - 4)).Range("C2:C" & LastRow)

Category = UniqueItems(Range1, False)

For i = 1 To UBound(Category)

Sheets(Left(fName, Len(fName) - 4)).Select

firstRow = Cells.Find(What:=Category(i), After:=[C1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=True).Row

LastRow = Cells.Find(What:=Category(i), After:=[C1], LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, MatchCase:=True).Row

If LastRow - firstRow > 10 Then

Set Rangex = Sheets(Left(fName, Len(fName) - 4)).Range("A" & firstRow & ":AA" & firstRow + 9)

Else

Set Rangex = Sheets(Left(fName, Len(fName) - 4)).Range("A" & firstRow & ":AA" & LastRow)

End If

Sheets("Top 10 Patch wise").Select

Range("BK1:BN12").Copy

Range("A" & f).Select
ActiveSheet.Paste

Application.CutCopyMode = False

Range("A" & f).Formula = "TOP TEN - " & Category(i)

Rangex.Copy

Range("A" & f + 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False

f = f + 13
Next i


Call savcor(fName)

End Sub
Sub savcor(ByVal fName As String)
Application.DisplayAlerts = False
sSavename = "C:\Data_Analysis\COR\" & Left(fName, Len(fName) - 4) & ".xls"
ActiveWorkbook.SaveAs FileName:=sSavename, FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True

Windows(Replace(UCase(fName), ".TXT", ".xls")).Close
End Sub


Raj

[MaximS]

All you missing is below function at the bottom.


Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements

Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean

' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True

' Counter for number of unique elements
NumUnique = 0

' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i

AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If

Next Element

' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function

[rajkumar]

Yes. I have that function in another module.But,I am getting another error now. attached the screenshot.

what could be the problem?

Raj :think:

[MaximS]

Function needs to go to each module where is used otherwise want work.
Macros cannot look for function in other Modules.

[rajkumar]

Ok. Pasted the same into the same module where macro is available,
But error remains.

Pls Help
Raj:think:

[MaximS]

can you try to run only this macro without runnning all other parts??

if still not working post sample file.

[mikerickson]

Function needs to go to each module where is used otherwise want work.
Macros cannot look for function in other Modules.
If a function is put in a normal module, it can be called from any module in the same workbook.
If a function is put in an object's module.(ThisWorkbook,Sheet modules or Userform module), it can be called by referencing the object.
If a function is in a class module, it can be called by referencing an instance of that class.

If myNormalFtn is in Module 1, this code in Module2, will work fine.

MsgBox myNormalFtn()
MsgBox Sheet1.mySheetFtn()
MsgBox ThisWorkbook.myWBFtn()
MsgBox UserForm1.myUFFtn()

Dim myClassObject As New Class1
MsgBox myClassObject.myClassyFtn()

[rajkumar]

Thanks for reply.

I have attached the sample here.

Extract them to C:\drive as the macro looks for that path.

Open the test.xls to check the error.

Raj : pray2:

[MaximS]

you getting that error because after proccessing your data in cor-blr and before creating TopTen in column "C" you have #N/A values after running following sub:

Sub PATCHCOR(ByVal fName As String)

and code

.Formula = "=VLOOKUP(RC[-1],'Reference Table.xls'!MIF_BASE,3,0)"

Review if #N/A values should be there and if yes you can change them into different value i.e. others or try vlookup against other value like Engineer No.

I've changed the #N/A values in column C to others and report has been created.

[rajkumar]

Cudos,

You are perfectly right. Now working. Thx

Raj :friends: