Analysis the top 26 vendors among all on a new sheet

[PRADEEPB270]

Pl.refer my attach file.

I want with the help of VBA codes to insert a new sheet for doing the analysis of top 26 vendors ( Pick-up the Highest Total from column 'I' of the vendor from 'summary' sheet ) details from the 'Summary'sheet.

Is it possible through the VBA codes help?

[Rudi]

You don't need code to do this. Just use a Pivot Table.
In the Rows field, place Vendor Name
In the Values field, place Total
Change the Total to calc with MAX
Filter the Vendor Name for the Top 26

Then you have your Analysis...

In the sample file I attached, I have done this but please note two important things:

1. Your labels are inconsistent...so the analysis is inaccurate!
>>> A G INDUSTRIES PVT. LTD. occurs three times because of inconsistent points in various places...

2. In order to create the Pivot table, you need to un-merge the labels in your summary sheet so the labels all occur on one row. look at Summary!B8:E8. I un-merged the cells and moved the labels to row 8. Only then can you create the Pivot.

[PRADEEPB270]

Yes,A.G.industries is repeating 3 times.But sir,all have different vendor code.Please see the summary sheet and column 'B'.
You are right pivot table is the option but can it be solve through VBA codes automatic?

[Rudi]

Yes,A.G.industries is repeating 3 times.But sir,all have different vendor code.Please see the summary sheet and column 'B'.
You are right pivot table is the option but can it be solve through VBA codes automatic?

The Vendor code does clear up that problem :)

I do not have time right now to create a generalized macro to run on a more dynamic basis, but here is a quick (recorded macro) that automates the setup of the pivot. Please note that it is using a FIXED range reference and will not be accurate if the list becomes longer or shorter.

[Rudi]

Sorry... I remembered I am on Office 2013 and a reference the the Pivot Table Version might debug if you are using version 2010 or older. If it does debug, try this version of the code.

Code: Select all

Sub CreatePivot2010()
Dim myRng As Range
    
    Set myRng = Application.InputBox("Select the range to pivot on. Include the column headings of the list!", Type:=8)
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Pivot").Delete
    On Error GoTo 0
    Sheets.Add(After:=ActiveSheet).Name = "Pivot"
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Summary!" & myRng.Address, Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:="Pivot!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion14
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor Name")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Total"), "Sum of Total", xlSum
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Total")
        .Caption = "Max of Total"
        .Function = xlMax
    End With
    ActiveSheet.PivotTables("PivotTable1").RowAxisLayout xlTabularRow
    Range("A5").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ").Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    Columns("A:A").EntireColumn.AutoFit
    Range("A4").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ").PivotFilters. _
        Add Type:=xlTopCount, DataField:=ActiveSheet.PivotTables("PivotTable1"). _
        PivotFields("Max of Total"), Value1:=26
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

Not working.Neither codes nor the file attach by you.Please refer my attach file.Is there any missing step by me?Pl.mention the clear to fine the tune.

[Rudi]

Not working.Neither codes nor the file attach by you.Please refer my attach file.Is there any missing step by me?Pl.mention the clear to fine the tune.

You did miss my previous instructions.

You needed to un-merge the column headings on the summary sheet so that the headings are in one row.
Also, you did not paste the macro code into the workbook you attached.

Unmerge.jpg

Unmerged.jpg

Here is a working copy of the process now. Test it out and see if it works OK.

[PRADEEPB270]

Not working till now.The problem is intact.I have downloaded your latest file but no satisfaction received.Please help in this matter

[Rudi]

Not working till now.The problem is intact.I have downloaded your latest file but no satisfaction received.Please help in this matter

Hi Pradeep,

I had to dig out a PC with Excel 2010 on, but when I tested, it did debug on the last line of code. It turns out that i overlooked a single reference to Excel 2013. When I changed it it worked fine on Excel 2010.

This version will work now on 2010. :)
Sorry for that.

[PRADEEPB270]

Hi Hansv,

Will you help me to solve this complicated VBA query in my msoffice version 2007?

[Rudi]

Hi Hansv,

Will you help me to solve this complicated VBA query in my msoffice version 2007?

I cannot test this code since I do not have access to Excel 2007.
But give this a go....

All I did was change the DefaultVersion from PivotTableVersion14 to PivotTableVersion12
(Version 12 is 2007)
(Version 10 is 2003)

Hopefully that works...

Code: Select all

Sub CreatePivot2007()
Dim myRng As Range
    
    Set myRng = Application.InputBox("Select the range to pivot on. Include the column headings of the list!", Type:=8)
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Pivot").Delete
    On Error GoTo 0
    Sheets.Add(After:=ActiveSheet).Name = "Pivot"
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Summary!" & myRng.Address, Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="Pivot!R3C1", TableName:="PivotTable1", DefaultVersion _
        :=xlPivotTableVersion12
    Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor Name")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("Total"), "Sum of Total", xlSum
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Sum of Total")
        .Caption = "Max of Total"
        .Function = xlMax
    End With
    ActiveSheet.PivotTables("PivotTable1").RowAxisLayout xlTabularRow
    Range("A5").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ").Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    Columns("A:A").EntireColumn.AutoFit
    Range("A4").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Vendor ").PivotFilters. _
        Add Type:=xlTopCount, DataField:=ActiveSheet.PivotTables("PivotTable1"). _
        PivotFields("Max of Total"), Value1:=26
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

Hi Rudi,

Pivot table is working now.Thanks for this efforts.
But the anticipated result has not achieved as I have shown in my posted thread,attach file and sheet'Analysis'.

Is this possible in that tabular form?
Please have a look once again my original post.

[Rudi]

I notice that the Vendor Code is different for the same Vendor Name?

Its going to be difficult to extract the Maximum Value for the top 26 vendors if their code and names are different (or not consistent).
Do you have a Vendor ID that stays the same for a specific vendor?
I'm not sure why your vendor code changes for the same vendor in the screenshot???

2013-11-22_13h33_53.jpg

[HansV]

Try the following macro:

Code: Select all

Sub CreateAnalysis()
    Dim wshS As Worksheet
    Dim wshA As Worksheet
    Dim r As Long
    Application.ScreenUpdating = False
    Set wshS = Worksheets("Summary")
    On Error Resume Next
    Set wshA = Worksheets("Analysis")
    On Error GoTo 0
    If wshA Is Nothing Then
        Set wshA = Worksheets.Add(After:=wshS)
        wshA.Name = "Analysis"
    Else
        wshA.Cells.Clear
    End If
    wshS.Range(wshS.Range("B8"), wshS.Range("B8").End(xlDown).Offset(ColumnOffset:=11)) _
        .Sort Key1:=wshS.Range("I8"), Order1:=xlDescending, Header:=xlYes
    wshS.Range("B3:M5").Copy Destination:=wshA.Range("B3")
    wshS.Range("B7:M34").Copy
    wshA.Range("B6").PasteSpecial Paste:=xlPasteValues
    wshA.Range("B6").PasteSpecial Paste:=xlPasteFormats
    wshA.Range("B6").PasteSpecial Paste:=xlPasteColumnWidths
    For r = 8 To 33
        wshA.Range("A" & r).Value = r - 7
    Next r
    wshA.Range("D34").Value = "SUBTOTAL FOR TOP 26 VENDORS (A)"
    wshA.Range("D35").Value = "PERCENTAGE COVERED"
    wshA.Range("D37").Value = "SUBTOTAL FOR OTHER VENDORS (B)"
    wshA.Range("D38").Value = "PERCENTAGE COVERED"
    wshA.Range("D40").Value = "TOTAL OF ALL VENDORS (A + B)"
    wshA.Range("D41").Value = "PERCENTAGE COVERED"
    With wshA.Range("D34:D41").Font
        .Bold = True
        .Color = vbRed
    End With
    With wshA.Range("F34:M34")
        .FormulaR1C1 = "=SUM(R8C:R33C)"
        .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
    End With
    With wshA.Range("F35:M35")
        .FormulaR1C1 = "=R34C/R40C"
        .NumberFormat = "0.00%"
    End With
    With wshA.Range("F37:M37")
        .FormulaR1C1 = "=R40C-R34C"
        .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
    End With
    With wshA.Range("F38:M38")
        .FormulaR1C1 = "=R37C/R40C"
        .NumberFormat = "0.00%"
    End With
    r = wshS.Range("F8").End(xlDown).Row
    With wshA.Range("F40:M40")
        .FormulaR1C1 = "=SUMMARY!R" & r & "C"
        .NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
    End With
    With wshA.Range("F41:M41")
        .Value = 1
        .NumberFormat = "0.00%"
    End With
    With wshA.Range("B7:M41")
        .BorderAround LineStyle:=xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
    End With
    wshA.Range("A1").Select
    Application.ScreenUpdating = True
End Sub

[PRADEEPB270]

well done Hansv.You are the real Excel's GOD.I am very happy to find the nice help from you.I will not forget your efforts.
Once again many-2 thanks for your awesome efforts.Very glad.

[PRADEEPB270]

Hi Hansv,

I am really very sorry at this moment.You have written above macro,no doubt it is working perfect.
But,in the future,if it is analysis of less than or more than 26 vendors instead of 26 ( Mention in above subject),then,in that case,macro will be completely re-write or slight modification.
Will you please guide for the suggestions?

[HansV]

I suggest that you study the code carefully and then adapt it.