Notice: WC_Cart::get_cart_url is deprecated since version 2.5! Use wc_get_cart_url instead. in /home/swatipaliwal/public_html/excelcrazy.com/wp-includes/functions.php on line 3839
Excel Crazy

Excel Pareto Add-In

What is Pareto Analysis?

The Pareto principle (also known as the 80/20 rule, the law of the vital few, or the principle of factor sparsity) states that, for many events, roughly 80% of the effects come from 20% of the causes.

Pareto analysis is a formal technique useful where many possible courses of action are competing for attention. In essence, the problem-solver estimates the benefit delivered by each action, then selects a number of the most effective actions that deliver a total benefit reasonably close to the maximal possible one. – Source “Wikipedia”

Some of the area’s where we can use Pareto principle

  • 80% of complaints we can resolve by working on 20% of issues
  • 80% of Sales in business by 20% of customers
  • 80% profit in business by 20% of customers
  • 80% of sales by 20% of sales peoples

This customized Pareto Add-in you can use on any dataset.

Step’s to install Add-In

  • First, save Add-In file in your Microsoft Add-In repository.
  • Now Activate your Add-In
  • To Activate click File Tab > Options > Add-Ins
  • Then from Inactive select, your add-in and hit go button.
  • In Popup box select Add-in and click ok

Now Assign Add-in to Ribbon

  • Click file tab > options > Customize Ribbon
  • Click New Tab > New Group
  • Select Macro in the choose commands from drop-box
  • Now assign your macro to ribbon

This Add-in holds three input controls

  1. Categorical Variable
  2. Variable hold values

Location where you want to create Pareto chart

Entire Code of Add-in:

Private Sub CreatePareto_Click()

Application.ScreenUpdating = False

    Dim filename As String
    Dim locaddress As String
    Dim valrng As Range
    Dim catrng As Range
    Dim rng As Range
    Dim cht As ChartObjects
    Dim rw As Long
    Dim cl As Long
    Dim lastrow As Long
    Dim rf As String
    Dim srtrng As Range
    Dim srtngrng As Range
    Dim chtcatrng As Range
    Dim valcatrng As Range
    Dim twentyrng As Range
    Dim eightyrng As Range
    Dim etycnt As Long
    Dim catl As Long
    Dim datasheet As String
    Dim removerng As Range
    
    
    Set valrng = Range(valrefedit.Text)
    Set catrng = Range(Catrefedit.Text)
    
    Set rng = Range(locationrefedit.Text).Resize(15, 7)

    filename = Left(locationrefedit.Text, InStr(locationrefedit.Text, "!") - 1)
    datasheet = Left(Catrefedit.Text, InStr(Catrefedit.Text, "!") - 1)
    
    locaddress = Right(locationrefedit.Text, Len(locationrefedit.Text) - InStr(locationrefedit.Text, "!"))
    
    ref = Application.WorksheetFunction.Substitute(locaddress, "$", "")
    'Debug.Print ref

    Dim MyNewSrs As Series
    Dim myChtObj As ChartObject
    
    rw = Worksheets(filename).Range(locaddress).Offset(0, 1).Row
    cl = Worksheets(filename).Range(locaddress).Offset(0, 1).Column
    
    
    rw1 = Worksheets(filename).Range(locaddress).Row
    cl1 = Worksheets(filename).Range(locaddress).Column
    
    Worksheets(filename).Range(locaddress).Resize(1, 5).EntireColumn.ClearContents
    
    Worksheets(datasheet).Activate
    Range(Catrefedit.Text).Cells(1, 1).Select
    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy Worksheets(filename).Range(locaddress)
    Worksheets(filename).Activate

    Worksheets(filename).Range(locaddress).Resize(1000000, 1).RemoveDuplicates Columns:=Array(1)
    
    Worksheets(filename).Range(locaddress).Offset(0, 1).Formula = "=sumifs(" & valrefedit & "," & Catrefedit & "," & ref & ")"

    lastrow = Worksheets(filename).Cells(1048576, cl1).End(xlUp).Row
    Worksheets(filename).Range(locaddress).Offset(0, 1).Copy
    Worksheets(filename).Range(locaddress).Offset(0, 1).Resize(lastrow - rw, 1).PasteSpecial xlPasteFormulas
    Application.CutCopyMode = False
    
    Worksheets(filename).Range(locaddress).Offset(0, 1).Resize(lastrow, 1).Copy
    Worksheets(filename).Range(locaddress).Offset(0, 1).PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    
    Set srtrng = Worksheets(filename).Range(locaddress).Offset(0, 1).Resize(lastrow, 1)
    Set srtngrng = Worksheets(filename).Range(locaddress).Offset(0, 1).Resize(lastrow, 2)
    
    
    ActiveWorkbook.Worksheets(filename).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(filename).Sort.SortFields.Add Key:=srtrng _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(filename).Sort
        .SetRange srtngrng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    Worksheets(filename).Range(locaddress).Offset(0, 1) = Range(valrefedit).Value
    Worksheets(filename).Range(locaddress).Offset(0, 2) = "Val Runing %"
    Worksheets(filename).Range(locaddress).Offset(0, 3) = "Cat %"
    
    Worksheets(filename).Range(locaddress).Offset(1, 2).FormulaR1C1 = "=SUM(R" & rw & "C" & cl & ":RC[-1])/SUM(R" & rw & "C" & cl & ":R" & lastrow & "C" & cl & ")"
    
    Worksheets(filename).Range(locaddress).Offset(1, 2).Copy
    Worksheets(filename).Range(locaddress).Offset(1, 2).Resize(lastrow - rw, 1).PasteSpecial xlPasteFormulas
    
    Application.CutCopyMode = False

    Worksheets(filename).Range(locaddress).Offset(1, 3).FormulaR1C1 = "=COUNTA(R" & rw1 & "C" & cl1 & ":RC[-3])/COUNTA(R" & rw1 & "C" & cl1 & ":R" & lastrow & "C" & cl1 & ")"
    
    Worksheets(filename).Range(locaddress).Offset(1, 3).Copy
    Worksheets(filename).Range(locaddress).Offset(1, 3).Resize(lastrow - rw, 1).PasteSpecial xlPasteFormulas
    
    Application.CutCopyMode = False
    
    Worksheets(filename).Range(locaddress).Offset(1, 4).FormulaR1C1 = "=COUNTA(R" & rw1 & "C" & cl1 & ":RC[-3])/COUNTA(R" & rw1 & "C" & cl1 & ":R" & lastrow & "C" & cl1 & ")"
    
    Worksheets(filename).Range(locaddress).Offset(1, 3).Copy
    Worksheets(filename).Range(locaddress).Offset(1, 3).Resize(lastrow - rw, 1).PasteSpecial xlPasteFormulas
    
    Application.CutCopyMode = False
    
    Worksheets(filename).Range(locaddress).Offset(0, 4).Value = "80% of Cutoff"
    Worksheets(filename).Range(locaddress).Offset(1, 4).FormulaR1C1 = "=IF(RC[-2]>0.8,0,VLOOKUP(0.81,C[-2],1,1))"
    Worksheets(filename).Range(locaddress).Offset(1, 4).Copy
    Worksheets(filename).Range(locaddress).Offset(1, 4).Resize(lastrow - rw, 1).PasteSpecial xlPasteFormulas
    
    Application.CutCopyMode = False
    
    Worksheets(filename).Range(locaddress).Offset(0, 2).Resize(lastrow, 3).NumberFormat = "0.0%"
    
    Set chtcatrng = Worksheets(filename).Range(locaddress).Offset(1, 3).Resize(lastrow, 1)
    Set chtvalrng = Worksheets(filename).Range(locaddress).Offset(1, 2).Resize(lastrow, 1)
    Set chteightyrng = Worksheets(filename).Range(locaddress).Offset(1, 4).Resize(lastrow, 1)
    
    etycnt = Application.WorksheetFunction.CountIfs(chtvalrng, "<0.8")
    custp = Application.WorksheetFunction.VLookup(0.8, Worksheets(filename).Range(locaddress).Offset(0, 2).Resize(lastrow, 2), 2, 1)
    
    Set myChtObj = Worksheets(filename).ChartObjects.Add _
            (Left:=rng.Left, Width:=rng.Width, Top:=rng.Top, Height:=rng.Height)
    
    With myChtObj.Chart
                .HasTitle = True
                .ChartTitle.Text = "Pareto Analysis"
                .ChartType = xlXYScatterLines
                .Axes(xlCategory, xlPrimary).HasTitle = True
                .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = Range(Catrefedit.Text).Cells(1, 1).Value & " %"
                .Axes(xlValue, xlPrimary).HasTitle = True
                .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = Range(valrefedit.Text).Cells(1, 1).Value & " %"
                With .SeriesCollection.NewSeries
                    .Name = Range(valrefedit.Text).Cells(1, 1).Value & " %"
                    .Values = chtvalrng
                    .XValues = chtcatrng
                    .ChartType = xlArea
                    .Format.Fill.ForeColor.Brightness = 0.6000000238
                End With
                With .SeriesCollection.NewSeries
                    .Name = "80% Cutoff"
                    .Values = chteightyrng
                    .XValues = chtcatrng
                    .ChartType = xlLine
                    .Format.Line.Visible = msoTrue
                    .Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
                    .Format.Line.ForeColor.TintAndShade = 0
                    .Format.Line.ForeColor.Brightness = 0.5
                    .Format.Line.Transparency = 0
                    .Format.Line.DashStyle = msoLineSysDash
                    .Points(etycnt).HasDataLabel = True
                    .Points(etycnt).DataLabel.Text = "80% ," & Format(custp, "Percent")
                End With

    End With
    
    myChtObj.Chart.Axes(xlValue).MajorGridlines.Select
    Selection.Delete
    myChtObj.Chart.ChartTitle.Text = "Pareto Analysis"
    ParetoAnalysis.Hide

Application.ScreenUpdating = True

End Sub

Download Pareto Add-In

November 1, 2017

0 responses on "Excel Pareto Add-In"

Leave a Message

Your email address will not be published. Required fields are marked *

top
 

© LOKESH PALIWAL 1987 - 2017

Reporting Solutions | Data Consulting | Analytics Training