Pareto charts in Excel with VBA macros

Private Sub UserForm_Initialize()
'This procedure executes before the
'userform is opened, and what text to show is
'determined by the public variable, bInput.
'bInput is declared in a module, but we'll
'get to that later.
If bInput Then
   Label1.Caption = "Select the cells (row or column) with " & _
   "the input values - and only them." & _
   "No total, no headlines - just the raw values. " & _
   "It can be in this or another workbook."
   Me.Caption = "Select input values"
Else
   Label1.Caption = "The macro must insert a table with " & _
   lRows & " rows and " & 5 & _
   " columns. Select a cell for the table's " & _
   "upper left cell. It can be in this or " & _
   "another workbook."
   Me.Caption = "Select where to insert"
End If
End Sub

'The OK button
Private Sub cmdOK_Click()
Unload Me
'If an input range has been selected,
'the procedure Analyze is called for
'check of input data.
If bInput Then
   Module1.Analyze
Else
   'If the user has just selected
   'where to put the table, we call
   'the procedure MakeTable to make
   'the sorted output table.
   Module1.MakeTable
End If
End Sub

'If the user cancelled
Private Sub cmdCancel_Click()
Unload Me
ThisWorkbook.Activate
End Sub

'If the user closes the userform by
'clicking the small cross in the upper
'right corner.
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then cmdCancel_Click
End Sub

Option Explicit
Public bAbort As Boolean   'Flag for abort
Public bInput As Boolean   'Flag for input data
Dim bVertical As Boolean   'Input data in column or not
Public lRows As Long       'Row variable
Dim sHeader As String      'Header
Dim sLabelHead As String   'Category header
Dim rCell As Range         'Range variable
Dim rInput As Range        'Range for input values
Dim rLabels As Range       'Range for categories
Dim rTotInput As Range     'Range for the whole input range
Dim arTable                'Array for table

Sub Start()
'The start procedure shows the userform
'frmSelect that will ask the user to
'select the range with input data, i.e.
'the input values used in the chart.

On Error GoTo ErrorHandle

bAbort = False
bVertical = False
sHeader = ""
sLabelHead = ""

'Set flag for selecting input data
bInput = True

'Show the userform in vbModeless, which
'makes it "float," while you do other
'things.
frmSelect.Show vbModeless

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Start"
End Sub

Sub Analyze()
'Controls if input values are valid

On Error GoTo ErrorHandle

'The range rInput is set = the range
'selected by the user.
Set rInput = Selection

'If the user selected only one cell
If rInput.Count = 1 Then
   MsgBox "You selected only 1 cell. Try again!"
   bAbort = True
   GoTo BeforeExit
End If

'Check if all values are numeric
For Each rCell In rInput
   If IsNumeric(rCell.Value) = False Then
      MsgBox "Cell " & rCell.Address & _
      " has a non numeric value."
      rCell.Select
      bAbort = True
      GoTo BeforeExit
   End If
Next

With rInput
   'Find out if input is a column or
   'a row. If it is a column, we set
   'bVertical = True
   If .Item(1).Row <> .Item(2).Row Then
      bVertical = True
      If .Column = 1 Then
         MsgBox "There must be categories in " & _
         "the column to the left of the values."
         GoTo BeforeExit
      End If
   End If

   If bVertical Then
      'More checking
      If .Columns.Count > 1 Then
         MsgBox "You selected more than one column"
         ThisWorkbook.Activate
         GoTo BeforeExit
      End If
      'Find headers if any
      If .Column > 1 Then
         Set rLabels = .Offset(0, -1)
      End If
      If .Item(1).Row > 1 Then
         If Len(.Item(1).Offset(-1, 0).Value) > 0 Then
            sHeader = .Item(1).Offset(-1, 0).Value
            sLabelHead = .Item(1).Offset(-1, -1).Value
            Set rTotInput = _
            Range(rLabels.Item(1).Offset(-1, 0), _
            rInput.Item(rInput.Count))
         Else
            'Set rTotInput = the whole input range.
            'This is used later to check if the
            'output table intersects with the
            'input data.
            Set rTotInput = _
            Range(rLabels.Item(1), _
            rInput.Item(rInput.Count))
         End If
      End If
   Else
      If .Rows.Count > 1 Then
         MsgBox "You selected more than 1 row"
         ThisWorkbook.Activate
         GoTo BeforeExit
      End If
      If .Row > 1 Then
         Set rLabels = .Offset(-1, 0)
      Else
         'A chart without categories is no good
         MsgBox "With input values in a row, " & _
         "the categories must be in the row above."
         GoTo BeforeExit
      End If
      'Headers and categories
      If .Item(1).Column > 1 Then
         sHeader = .Item(1).Offset(0, -1).Value
         sLabelHead = .Item(1).Offset(-1, -1).Value
         Set rTotInput = _
         Range(rLabels.Item(1).Offset(0, -1), _
         rInput.Item(rInput.Count))
      Else
         Set rTotInput = _
         Range(rLabels.Item(1), _
         rInput.Item(rInput.Count))
      End If
   End If
End With

'The number of rows in the output table
'equals the number of input values + header
lRows = rInput.Count + 1

'Now the user must select where to put
'the new table, so we set bInput = False
bInput = False

'Show the userform
frmSelect.Show vbModeless

BeforeExit:
On Error Resume Next

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Analyze"
bAbort = True
Resume BeforeExit
End Sub

Sub MakeTable()
'This procedure is called, when the user
'has selected where to put the new table.
'First we check if the new table will
'overwrite input data, and then we make
'the new table with sorted values and
'accumulated percent.
Dim lCount As Long      'Counter
Dim lLow As Long        'Counter
Dim dOthers As Double   'Sum of small values
Dim dPct As Double      'Percent variable
Dim dSum As Double      'Sum
Dim sAddress As String
Dim rFirstCell As Range
Dim rNewTable As Range
Dim vInput              'Variable for user input
Dim arTemp()            'Array
Dim arPct()             'Array

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

'rFirstCell is set = the cell selected by user
Set rFirstCell = Selection

'rCell is set = the new (empty) table, and we
'check if it will intersect with input data.
'If it does, we abort.
Set rCell = rFirstCell.Resize(rInput.Count + 1, 5)
Set rCell = Application.Intersect(rCell, rTotInput)
If Not rCell Is Nothing Then
    MsgBox "The new table will overwrite " & vbNewLine & _
    "input data. Select another cell.", , "Conflict"
    GoTo BeforeExit
End If

'If the user has selected more than
'one cell, we select the first.
If rFirstCell.Count > 1 Then
   Set rFirstCell = rFirstCell.Item(1)
End If

'Insert headers (if any), and categories
'plus values are copied to the new table.
With rFirstCell
   .Value = sLabelHead
   .Offset(0, 1).Value = sHeader
   If bVertical Then
      rLabels.Copy .Offset(1, 0)
      rInput.Copy .Offset(1, 1)
   Else
      For lCount = 1 To rInput.Count
         .Offset(lCount).Value = rLabels.Item(lCount).Value
         .Offset(lCount, 1).Value = rInput.Item(lCount).Value
      Next
   End If
End With

'rNewTable is set = the new table
Set rNewTable = Range(rFirstCell, _
rFirstCell.Offset(lRows - 1, 1))

'Sort the new table descending
rNewTable.Sort Key1:=rNewTable.Item(2), _
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'We need the total to calculate the
'categories' percentages
dSum = WorksheetFunction.Sum(rInput)

'Copy the table to the array, arTemp
arTemp = rNewTable.Value

'Redimension the percent array
ReDim arPct(1 To UBound(arTemp))

'Calculate the frequency percentages to see,
'if there are some small values that in total
'are less than 5%.
For lCount = UBound(arTemp) To 2 Step -1
   arPct(lCount) = arTemp(lCount, 2) * 100 / dSum
   If arPct(lCount) + dPct < 5 Then
      lLow = lLow + 1
      dPct = dPct + arPct(lCount)
      dOthers = _
      dOthers + rFirstCell.Offset(lCount - 1, 1).Value
   Else
      Exit For
   End If
Next

'If the total of small records is less than 5%, we
'ask the user if we should pool then in a record
'called "Others".
If lLow > 1 Then
   vInput = MsgBox("The " & lLow & _
   " smallest categories are less than 5% in total." & _
   vbNewLine & _
   "Do you want to pool them in one category " & _
   "called ""Others""?", vbYesNo, "Small categories")
   'If the user said yes, we delete the rows with
   'the smalles categories and pool them into one
   'called "Others".
   If vInput = vbYes Then
      For lCount = lRows To lRows - lLow + 1 Step -1
         rNewTable.Rows(lCount).Delete
      Next
      With rFirstCell
         .Offset(lCount).Value = "Others"
         .Offset(lCount, 1).Value = dOthers
      End With
      
      'Redimension rNewTable to the new number of rows
      Set rNewTable = _
      rNewTable.Resize(rNewTable.Rows.Count + 1)
      
      'Update the variable with number of rows
      lRows = rNewTable.Rows.Count
      
      'Sort the new table with descending values
      rNewTable.Sort Key1:=rNewTable.Item(2), _
      Order1:=xlDescending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal
   End If
End If

'Redimension arTable to the number of rows in
'rNewTable and 3 columns
ReDim arTemp(1 To lRows, 1 To 3)

'Set the range rFirstCell = the first
'cell in rNewTable's second column.
Set rFirstCell = rNewTable.Item(2)

'Redimension rNewTable to contain the whole
'table. We use this, when we make the chart.
Set rNewTable = rNewTable.Resize(lRows, 4)

'If the following line is omitted, the chart
'may look funny (wrong) in some Excel versions.
'I don't know why - ask an expert!
rNewTable.Select

arTemp(1, 1) = "Akk. %"
'Notice the apostrophe before "80%". If
'omitted, Excel may change the cell format
'to percent, and we don't want that.
arTemp(1, 2) = "'80%"
arTemp(1, 3) = "Acc. frequency"

With rFirstCell
   'Accumulated % 1. line
   arTemp(2, 1) = _
   "=" & .Offset(1, 3).Address & _
   "*100/" & .Offset(lRows - 1, 3).Address
   '80% line
   arTemp(2, 2) = 80
   'Accumulated frequency 1. line
   arTemp(2, 3) = "=" & .Offset(1, 0).Address
   
   'We fill the rest with a loop.
   For lCount = 3 To lRows
      'Accumulated percent
      arTemp(lCount, 1) = _
      "=" & .Offset(lCount - 1, 3).Address & _
      "*100/" & .Offset(lRows - 1, 3).Address
      '80 for the 80% line
      arTemp(lCount, 2) = 80
      'Accumulated frequency
      arTemp(lCount, 3) = _
      "=" & .Offset(lCount - 1, 0).Address & _
      "+" & .Offset(lCount - 2, 3).Address
   Next
End With

'Redimension rFirstCell to the same size as
'the array arTemp, so we can insert the
'table in one swift operation.
Set rFirstCell = rFirstCell.Offset(0, 1)
Set rFirstCell = rFirstCell.Resize(lRows, 3)
'Copy the formulas in arTemp to the table range
rFirstCell.Formula = arTemp

'Set rCell = the range with values, so we
'can format the numbers.
Set rCell = rFirstCell.Resize(lRows - 1, 4)
Set rCell = rCell.Offset(1, -1)
With rCell
   'We don't want decimals for frequencies
   .NumberFormat = "0"
   '2 decimals for percentages
   .Columns(3).NumberFormat = "#.00"
End With

'Now it is time to make the chart.
'This is done by the procedure MakeParetoChart
MakeParetoChart rNewTable

BeforeExit:
On Error Resume Next
Set rCell = Nothing
Set rInput = Nothing
Set rLabels = Nothing
Set rFirstCell = Nothing
Set rNewTable = Nothing
Set rTotInput = Nothing
Erase arPct
Erase arTable
Erase arTemp
Application.ScreenUpdating = True
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure MakeTable"
End Sub

Sub MakeParetoChart(ByVal rTable As Range)
'This procedure is almost identical to the
'one made by the macro recorder. I have
'just changed a few things. You can make
'it more efficient, e.g. by not selecting
'objects.
Dim sSheet As String

On Error GoTo ErrorHandle

sSheet = ActiveSheet.Name

Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData _
Source:=Sheets(sSheet).Range(rTable.Address)
ActiveChart.Location Where:=xlLocationAsObject, Name:=sSheet
ActiveChart.SeriesCollection(2).Select
ActiveChart.SeriesCollection(2).ChartType = xlLineMarkers
ActiveChart.SeriesCollection(3).Select
With Selection.Border
    .ColorIndex = 5
    .Weight = xlMedium
    .LineStyle = xlContinuous
End With
Selection.Shadow = False
Selection.InvertIfNegative = False
With Selection.Interior
    .ColorIndex = 5
    .Pattern = xlSolid
End With
ActiveChart.SeriesCollection(3).AxisGroup = 2
ActiveChart.SeriesCollection(3).ChartType = xlLine
ActiveChart.SeriesCollection(2).Select
With Selection.Border
    .ColorIndex = 3
    .Weight = xlMedium
    .LineStyle = xlContinuous
End With
With Selection
    .MarkerBackgroundColorIndex = 3
    .MarkerForegroundColorIndex = 3
    .MarkerStyle = xlSquare
    .Smooth = False
    .MarkerSize = 7
    .Shadow = False
End With
ActiveChart.SeriesCollection(2).AxisGroup = 2
ActiveChart.PlotArea.Select
With Selection.Border
    .ColorIndex = 16
    .Weight = xlThin
    .LineStyle = xlContinuous
End With
With Selection.Interior
    .ColorIndex = 2
    .PatternColorIndex = 1
    .Pattern = xlSolid
End With
ActiveChart.Axes(xlValue, xlSecondary).Select
With ActiveChart.Axes(xlValue, xlSecondary)
    .MinimumScaleIsAuto = True
    .MaximumScale = 100
    .MinorUnitIsAuto = True
    .MajorUnitIsAuto = True
    .Crosses = xlAutomatic
    .ReversePlotOrder = False
    .ScaleType = xlLinear
    .DisplayUnit = xlNone
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Border
    .ColorIndex = 1
    .Weight = xlThin
    .LineStyle = xlContinuous
End With
Selection.Shadow = False
Selection.InvertIfNegative = False
With Selection.Interior
    .ColorIndex = 15
    .Pattern = xlSolid
End With
With ActiveChart.ChartGroups(1)
    .Overlap = 0
    .GapWidth = 0
    .HasSeriesLines = False
    .VaryByCategories = False
End With
With ActiveChart
    .HasTitle = True
    .ChartTitle.Characters.Text = "Title"
End With

Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure MakeParetoChart"
End Sub