1. To significantly reduce time spent in generating the daily pareto of defects without sacrificing data integrity and accuracy in calculations.
Methodology
Common method of defining the data block is to create a range by dragging the mouse from corner to corner of the data block, i.e. dragging the mouse from one corner towards the diagonal opposite corner.
This method is cumbersome, sometimes to the point of annoying especially when we are to analyze hundreds of production lots where one end or corner of the data block is already outside the view of our computer screen.
This macro requires only selection of first column of the data block which can be easily accomplished using shift+ctrl+end and pressing the arrow up or down once. The macro locates the other end of the data block.
Scope and Limitations
This macro requires that the data will be in the following format.
Though not necessary ( because calculations will still be correct ), empty cells must be filled with zeros to avoid the appearance of green triangular tags on cells containing the totals when this macro is executed.
I think this will not be much of a problem because common to manufacturing databases for work in process, to automatically fill these empty cells with zeros during data extraction or when the database table is exported as excel table.
Code
'Module 1
Option Explicit
Public lastRowRange As Range
Public aCellRange1 As Range
Sub ColumnTotals()
'Calculation of columns' Total and Grand Total
'variables and strings
Dim Prompt1 As String
Dim Title1 As String
'initialize variables
Prompt1 = "Select first column of Defect data"
Title1 = "Calculation of Column Totals"
Set firstColRange = Nothing
Set lastRowRange = Nothing
Set aCellRange1 = Nothing
'error handling
On Error Resume Next
Set firstColRange = Application.InputBox( _
prompt:=Prompt1, _
Title:=Title1, _
Left:=25, Top:=25, _
Type:=8) 'Range selection
'remove error handling
On Error GoTo 0
'Exit sub if canceled
If firstColRange Is Nothing Then Exit Sub
'turn off screen update
Application.ScreenUpdating = False
'derive lastRowRange (single cell)
Set lastRowRange = firstColRange(firstColRange.Count)
'get index of last column through loop
lastRowRange.Select
Do While IsEmpty(ActiveCell) = False
ActiveCell.Offset(0, 1).Select
Loop
'redefine lastRowRange
Set lastRowRange = Range(lastRowRange, ActiveCell _
.Offset(0, -1))
'calculate column totals
'offset and select lastRowRange
lastRowRange.Offset(1, 0).Select
'insert formula to cells of lastRowRange
Selection.FormulaR1C1 = "=sum(R[-" & firstColRange.Count _
& "]C:R[-1]C)"
'calculate grand total
'derive a cell and move to totals area
Set aCellRange1 = firstColRange(firstColRange.Count)
aCellRange1.Offset(1, -1).Select
'insert fomula ('ActiveCell' is proper than 'Selection')
ActiveCell.Formula = "=sum(" & _
lastRowRange.Offset(1, 0).Address & ")"
'insert label of Row
aCellRange1.Offset(1, -2).Value = "Column Totals"
'sub procedure calls
Call PercentContribution
Call DescendingOrder
Call CommulativeDistribution
Call ParetoGraph
End Sub
''==============================================================
'Module 2
Option Explicit
Sub PercentContribution()
'Calculation of Per cent Contribution per defect
'offset to 1st empty row below
lastRowRange.Offset(2, 0).Select
'insert %defect formula to cells of lastRowRange
Selection.FormulaR1C1 = "=R[-1]C/R" & _
aCellRange1.Offset(1, -1).Row & _
"C" & aCellRange1.Offset(1, -1).Column
'change format to percent
Selection.Style = "Percent"
'calculate grand total of per cent contributions
aCellRange1.Offset(2, -1).Select
ActiveCell.Formula = "=sum(" & _
lastRowRange.Offset(2, 0).Address & ")"
'change format of grand total to per cent
ActiveCell.Style = "Percent"
'insert label of Row
aCellRange1.Offset(2, -2).Value = "Per Cent Contribution"
End Sub
''==============================================================
'Module 3
Option Explicit
Sub DescendingOrder()
'Arrange per cent defect to decending order
'select columns (entire column) of defects
lastRowRange.EntireColumn.Select
'set sorting parameters
Selection.Sort _
Key1:=aCellRange1.Offset(2, 0), _
Order1:=xlDescending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
End Sub
''==============================================================
'Module 4
Option Explicit
Sub CommulativeDistribution()
'Calculation of Commulative Distribution
'offset to 1st empty row below
lastRowRange.Offset(3, 0).Select
'insert % commulative formula to cells of lastRowRange
Selection.FormulaR1C1 = "=RC[-1]+R[-1]C"
'change format to percent
Selection.Style = "Percent"
'replace formula of 1st cell with just a reference
'to the 1st per cent defect
aCellRange1.Offset(3, 0).Select
ActiveCell.Formula = "=R[-1]C"
'change format of 1st to per cent (just to ensure)
ActiveCell.Style = "Percent"
'insert label of Row
aCellRange1.Offset(3, -2).Value = "Per Cent Commulative"
End Sub
''==============================================================
'Module 5
Option Explicit
Sub ParetoGraph()
'generate embedded pareto chart
'get sheet name where lastRowRange resides
Dim shtName As String
shtName = lastRowRange.Worksheet.Name
'create range for x axis labels
Dim xAxisLabel As Range
Set xAxisLabel = lastRowRange.Offset(-firstColRange.Count, 0)
'redefine lastRowRange (increase by 1 row)
Set lastRowRange = lastRowRange. _
Resize(2, lastRowRange.Columns.Count)
'select datasource
lastRowRange.Offset(2, 0).Select
'add chart
Charts.Add
'set chart properties
With ActiveChart
'define chart type
.ChartType = xlColumnClustered
'Location of chart
.Location Where:=xlLocationAsObject, Name:=shtName
End With
'==================
With ActiveChart.SeriesCollection(1)
'set legend of the series 1 source data
.Name = aCellRange1.Offset(2, -2).Value
'x axis labels
.XValues = Worksheets(shtName).Range(xAxisLabel.Address)
End With
'==================
With ActiveChart.SeriesCollection(2)
'assign to secondary axis
.AxisGroup = 2
'change chartType of Per cent commulative
.ChartType = xlLineMarkers
'set legend of the series 2 source data
.Name = aCellRange1.Offset(3, -2).Value
End With
'==================
With ActiveChart.Axes(xlValue, xlSecondary)
'set maximum scale value
.MaximumScale = 1
'set minimum scale value
.MinimumScale = 0
End With
'==================
With ActiveChart
'show title
.HasTitle = True
'set title content
.ChartTitle.Characters.Text = "Pareto of Defects as of " _
& Strings.MonthName(DateTime.Month(Now)) & " " _
& DateTime.Day(Now) & ", " _
& DateTime.Year(Now)
'show Y axis title
.Axes(xlValue, xlPrimary).HasTitle = True
'set Y axis title
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = _
"% Defect"
'chart area properties
.ChartArea.Select
'set autoscale false
Selection.AutoScaleFont = False
'set font properties
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
'plot area properties
.PlotArea.Select
'plotarea border properties
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
'plotarea background properties (no color)
Selection.Interior.ColorIndex = xlNone
'deselect chart
ActiveChart.Deselect
End With
End Sub
Option Explicit
'Module wide variables
Public firstColRange As RangePublic lastRowRange As Range
Public aCellRange1 As Range
Sub ColumnTotals()
'Calculation of columns' Total and Grand Total
'variables and strings
Dim Prompt1 As String
Dim Title1 As String
'initialize variables
Prompt1 = "Select first column of Defect data"
Title1 = "Calculation of Column Totals"
Set firstColRange = Nothing
Set lastRowRange = Nothing
Set aCellRange1 = Nothing
'error handling
On Error Resume Next
Set firstColRange = Application.InputBox( _
prompt:=Prompt1, _
Title:=Title1, _
Left:=25, Top:=25, _
Type:=8) 'Range selection
'remove error handling
On Error GoTo 0
'Exit sub if canceled
If firstColRange Is Nothing Then Exit Sub
'turn off screen update
Application.ScreenUpdating = False
'derive lastRowRange (single cell)
Set lastRowRange = firstColRange(firstColRange.Count)
'get index of last column through loop
lastRowRange.Select
Do While IsEmpty(ActiveCell) = False
ActiveCell.Offset(0, 1).Select
Loop
'redefine lastRowRange
Set lastRowRange = Range(lastRowRange, ActiveCell _
.Offset(0, -1))
'calculate column totals
'offset and select lastRowRange
lastRowRange.Offset(1, 0).Select
'insert formula to cells of lastRowRange
Selection.FormulaR1C1 = "=sum(R[-" & firstColRange.Count _
& "]C:R[-1]C)"
'calculate grand total
'derive a cell and move to totals area
Set aCellRange1 = firstColRange(firstColRange.Count)
aCellRange1.Offset(1, -1).Select
'insert fomula ('ActiveCell' is proper than 'Selection')
ActiveCell.Formula = "=sum(" & _
lastRowRange.Offset(1, 0).Address & ")"
'insert label of Row
aCellRange1.Offset(1, -2).Value = "Column Totals"
'sub procedure calls
Call PercentContribution
Call DescendingOrder
Call CommulativeDistribution
Call ParetoGraph
End Sub
''==============================================================
'Module 2
Option Explicit
Sub PercentContribution()
'Calculation of Per cent Contribution per defect
'offset to 1st empty row below
lastRowRange.Offset(2, 0).Select
'insert %defect formula to cells of lastRowRange
Selection.FormulaR1C1 = "=R[-1]C/R" & _
aCellRange1.Offset(1, -1).Row & _
"C" & aCellRange1.Offset(1, -1).Column
'change format to percent
Selection.Style = "Percent"
'calculate grand total of per cent contributions
aCellRange1.Offset(2, -1).Select
ActiveCell.Formula = "=sum(" & _
lastRowRange.Offset(2, 0).Address & ")"
'change format of grand total to per cent
ActiveCell.Style = "Percent"
'insert label of Row
aCellRange1.Offset(2, -2).Value = "Per Cent Contribution"
End Sub
''==============================================================
'Module 3
Option Explicit
Sub DescendingOrder()
'Arrange per cent defect to decending order
'select columns (entire column) of defects
lastRowRange.EntireColumn.Select
'set sorting parameters
Selection.Sort _
Key1:=aCellRange1.Offset(2, 0), _
Order1:=xlDescending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal
End Sub
''==============================================================
'Module 4
Option Explicit
Sub CommulativeDistribution()
'Calculation of Commulative Distribution
'offset to 1st empty row below
lastRowRange.Offset(3, 0).Select
'insert % commulative formula to cells of lastRowRange
Selection.FormulaR1C1 = "=RC[-1]+R[-1]C"
'change format to percent
Selection.Style = "Percent"
'replace formula of 1st cell with just a reference
'to the 1st per cent defect
aCellRange1.Offset(3, 0).Select
ActiveCell.Formula = "=R[-1]C"
'change format of 1st to per cent (just to ensure)
ActiveCell.Style = "Percent"
'insert label of Row
aCellRange1.Offset(3, -2).Value = "Per Cent Commulative"
End Sub
''==============================================================
'Module 5
Option Explicit
Sub ParetoGraph()
'generate embedded pareto chart
'get sheet name where lastRowRange resides
Dim shtName As String
shtName = lastRowRange.Worksheet.Name
'create range for x axis labels
Dim xAxisLabel As Range
Set xAxisLabel = lastRowRange.Offset(-firstColRange.Count, 0)
'redefine lastRowRange (increase by 1 row)
Set lastRowRange = lastRowRange. _
Resize(2, lastRowRange.Columns.Count)
'select datasource
lastRowRange.Offset(2, 0).Select
'add chart
Charts.Add
'set chart properties
With ActiveChart
'define chart type
.ChartType = xlColumnClustered
'Location of chart
.Location Where:=xlLocationAsObject, Name:=shtName
End With
'==================
With ActiveChart.SeriesCollection(1)
'set legend of the series 1 source data
.Name = aCellRange1.Offset(2, -2).Value
'x axis labels
.XValues = Worksheets(shtName).Range(xAxisLabel.Address)
End With
'==================
With ActiveChart.SeriesCollection(2)
'assign to secondary axis
.AxisGroup = 2
'change chartType of Per cent commulative
.ChartType = xlLineMarkers
'set legend of the series 2 source data
.Name = aCellRange1.Offset(3, -2).Value
End With
'==================
With ActiveChart.Axes(xlValue, xlSecondary)
'set maximum scale value
.MaximumScale = 1
'set minimum scale value
.MinimumScale = 0
End With
'==================
With ActiveChart
'show title
.HasTitle = True
'set title content
.ChartTitle.Characters.Text = "Pareto of Defects as of " _
& Strings.MonthName(DateTime.Month(Now)) & " " _
& DateTime.Day(Now) & ", " _
& DateTime.Year(Now)
'show Y axis title
.Axes(xlValue, xlPrimary).HasTitle = True
'set Y axis title
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = _
"% Defect"
'chart area properties
.ChartArea.Select
'set autoscale false
Selection.AutoScaleFont = False
'set font properties
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
'plot area properties
.PlotArea.Select
'plotarea border properties
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
'plotarea background properties (no color)
Selection.Interior.ColorIndex = xlNone
'deselect chart
ActiveChart.Deselect
End With
End Sub
NOTES in using this macro.
1. READ DISCLAIMER First.
2. This is a macro for Excel Version 2003.
3. This macro takes advantage of the benefits of Object Oriented Programming (OOP). This is the reason why I divided the entire procedure into five (5) modules - makes debugging easier for me. Copy codes to their respective modules and Execute only module 1 (Sub ColumnTotals()). Modules 2 to 5 are called from module 1 and should not be executed alone.
4. Error handling.
This program uses error handling features of VBA, therefore you need to activate "Break on Unhandled Errors" in the Options dialog box of VBE ( Visual Basic Editor ). Here's how to do it.
Alt + F11 (keyboard) ; Options (menu) ; General (Tab) ; Break on Unhandled Errors (Sub group)
No program is guaranted error free (errors are only undiscovered) so for the errors you will discover, dont get disappointed, just try to duplicate the condtions as near as you can to the conditions instructed here.
2. This is a macro for Excel Version 2003.
3. This macro takes advantage of the benefits of Object Oriented Programming (OOP). This is the reason why I divided the entire procedure into five (5) modules - makes debugging easier for me. Copy codes to their respective modules and Execute only module 1 (Sub ColumnTotals()). Modules 2 to 5 are called from module 1 and should not be executed alone.
4. Error handling.
This program uses error handling features of VBA, therefore you need to activate "Break on Unhandled Errors" in the Options dialog box of VBE ( Visual Basic Editor ). Here's how to do it.
Alt + F11 (keyboard) ; Options (menu) ; General (Tab) ; Break on Unhandled Errors (Sub group)
No program is guaranted error free (errors are only undiscovered) so for the errors you will discover, dont get disappointed, just try to duplicate the condtions as near as you can to the conditions instructed here.
Conclusion
Draw your own conclusion. Compare the effectiveness of this macro by generating the pareto chart through step by step method. Compare the total time consumed and total number of hand movements made.
