Pareto-diagram i Excel med VBA makroer

Private Sub UserForm_Initialize()
'Denne procedure kører, før formularen
'åbnes, og hvilken tekst der vises i
'Label1, afgøres af den globale variabel, bInput.
'bInput er deklareret i et modul - 
'det kommer vi til.
If bInput Then
   Label1.Caption = "Markér området (række eller kolonne) med " & _
   "inputværdier og kun dem. Ingen sum, ingen overskrifter - " & _
   "kun de rå værdier for kategorierne. Det kan være i " & _
   "dette eller et andet regneark."
   Me.Caption = "Vælg området med værdier"
Else
   Label1.Caption = "Makroen skal indsætte end tabel " & _
    "med " & lRows & " rækker og 5 kolonner. " & _
    "Vælg en celle til tabellens øverste venstre " & _
    "celle. Det kan være i dette eller et andet regneark."
   Me.Caption = "Vælg indsætningspunkt"
End If
End Sub

'OK-knappen
Private Sub cmdOK_Click()
Unload Me
'Hvis der netop er udpeget inputområde
'kaldes proceduren Analyze for tjek af
'inputdata.
If bInput Then
   Module1.Analyze
Else
   'Hvis brugeren netop har markeret,
   'hvor tabellen skal sættes ind,
   'kaldes proceduren MakeTable, som
   'laver den sorterede output-tabel.
   Module1.MakeTable
End If
End Sub

'Hvis brugeren annullerer
Private Sub cmdCancel_Click()
Unload Me
ThisWorkbook.Activate
End Sub

'Hvis brugeren lukker formularen ved at
'klikke på det lille kryds øverst til højre.
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 afbrudt
Public bInput As Boolean   'Flag for inputdata
Dim bVertical As Boolean   'Inputdata i kolonne eller ej
Public lRows As Long       'Rækkevariabel
Dim sHeader As String      'Overskrift
Dim sLabelHead As String   'Kategorioverskrift
Dim rCell As Range         'Range-variabel
Dim rInput As Range        'Range for inputværdierne
Dim rLabels As Range       'Range for kategorierne
Dim rTotInput As Range     'Range for hele inputområdet
Dim arTable                'Array til tabel

Sub Start()
'Startproceduren viser Userformen frmSelect,
'som beder brugeren markere området med
'inputværdierne - altså tallene, som bruges
'til søjlerne.

On Error GoTo ErrorHandle

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

'Flag for at det nu er området med
'inputdata, der skal udpeges.
bInput = True

'Vis frmSelect i tilstanden vbModeless,
'som gør, at den "flyder," mens man kan
'lave andre ting.
frmSelect.Show vbModeless

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

Sub Analyze()
'Kontrollerer om inputdata er valide

On Error GoTo ErrorHandle

'Ranget rInput sættes = det det område,
'brugeren har markeret.
Set rInput = Selection

'Hvis der kun er markeret 1 celle
If rInput.Count = 1 Then
   MsgBox "Du har kun valgt 1 celle. Prøv igen!"
   bAbort = True
   GoTo BeforeExit
End If

'Tjek om alle værdier er numeriske
For Each rCell In rInput
   If IsNumeric(rCell.Value) = False Then
      MsgBox "Celle " & rCell.Address & _
      " indeholder en ikke-numerisk værdi."
      rCell.Select
      bAbort = True
      GoTo BeforeExit
   End If
Next

With rInput
   'Find ud af, om input er en kolonne
   'eller en række. Hvis det er en kolonne
   'sættes bVertical = True.
   If .Item(1).Row <> .Item(2).Row Then
      bVertical = True
      If .Column = 1 Then
         MsgBox "Der skal være kategorier i " & _
         "kolonnen til venstre for værdierne."
         GoTo BeforeExit
      End If
   End If

   If bVertical Then
      'Mere kontrol
      If .Columns.Count > 1 Then
         MsgBox "Du har valgt mere end 1 kolonne"
         ThisWorkbook.Activate
         GoTo BeforeExit
      End If
      'Find overskrifter, hvis der er nogen
      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
            'Sæt rTotInput = hele inputområdet.
            'Bruges senere til kontrol af om
            'outputtabellen overskriver inputdata.
            Set rTotInput = _
            Range(rLabels.Item(1), rInput.Item(rInput.Count))
         End If
      End If
   Else
      If .Rows.Count > 1 Then
         MsgBox "Du har valgt mere end 1 række"
         ThisWorkbook.Activate
         GoTo BeforeExit
      End If
      If .Row > 1 Then
         Set rLabels = .Offset(-1, 0)
      Else
         'Et diagram uden kategorier er ikke meget værd ...
         MsgBox "Ved værdier i en række, " & _
         "skal kategorierne stå i rækken ovenover."
         GoTo BeforeExit
      End If
      'Overskrifter og kategorier
      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

'Antal rækker i output-tabellen er antal
'input-værdier + overskrift.
lRows = rInput.Count + 1

'Nu skal brugeren vælge indsætningspunkt
'for den nye tabel, og derfor sættes
'bInput = False
bInput = False

'Vis formularen
frmSelect.Show vbModeless

BeforeExit:
On Error Resume Next

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

Sub MakeTable()
'Denne procedure kaldes, når brugeren har
'valgt indsætningspunkt for den nye tabel.
'Først tjekkes, om den nye tabel vil
'overskrive inputdata, og derefter laves
'den nye tabel med sorterede værdier og
'akkumuleret procent.
Dim lCount As Long      'Tæller
Dim lLow As Long        'Tæller
Dim dOthers As Double   'Sum af små værdier
Dim dPct As Double      'Procent-variabel
Dim dSum As Double      'Sum
Dim sAddress As String
Dim rFirstCell As Range
Dim rNewTable As Range
Dim vInput              'Variabel til brugersvar
Dim arTemp()            'Array
Dim arPct()             'Array

On Error GoTo ErrorHandle

Application.ScreenUpdating = False

'rFirstCell sættes = den brugervalgte celle
Set rFirstCell = Selection

'rCell sættes nu lig den nye tabel (uden indhold)
'og det tjekkes, om den vil overlappe inputdata.
'Gør den det, afbryder vi operationen.
Set rCell = rFirstCell.Resize(rInput.Count + 1, 5)
Set rCell = Application.Intersect(rCell, rTotInput)
If Not rCell Is Nothing Then
    MsgBox "Den nye tabel vil overskrive dele af " & vbNewLine & _
    "de originale kildedata. Vælg en anden celle.", , "Konflikt"
    GoTo BeforeExit
End If

'Har brugeren valgt mere end 1 celle,
'vælger vi den første.
If rFirstCell.Count > 1 Then
   Set rFirstCell = rFirstCell.Item(1)
End If

'Evt. overskrifter indsættes, og kategorier
'samt værdier kopieres til den nye tabel.
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 sættes = den nye tabel
Set rNewTable = Range(rFirstCell, rFirstCell.Offset(lRows - 1, 1))

'Sorter den nye tabel med faldende værdier
rNewTable.Sort Key1:=rNewTable.Item(2), _
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'Vi skal bruge summen til at beregne de enkelte
'kategoriers procentuelle andel.
dSum = WorksheetFunction.Sum(rInput)

'Kopierer tabellen til arrayet arTemp
arTemp = rNewTable.Value

'Redimensionerer arrayet arPct til samme
'antal rækker.
ReDim arPct(1 To UBound(arTemp))

'Frekvenserne regnes ud i procent for at se,
'om der er nogle små poster, som tilsammen
'udgør mindre end 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

'Hvis flere små poster tilsammen udgør mindre end 5 %,
'spørger vi brugeren, om de skal slås sammen til én
'post kaldet "Andet".
If lLow > 1 Then
   vInput = MsgBox("De " & lLow & _
   " mindste kategorier udgør tilsammen mindre end 5 %." & _
   vbNewLine & _
   "Skal de slås sammen til én kategori " & _
   "kaldet ""Andet""?", vbYesNo, "Små kategorier")
   'Hvis brugeren svarede ja, sletter vi rækkerne
   'med de mindste poster og slår dem sammen i én,
   'som vi kalder "Andet".
   If vInput = vbYes Then
      For lCount = lRows To lRows - lLow + 1 Step -1
         rNewTable.Rows(lCount).Delete
      Next
      With rFirstCell
         .Offset(lCount).Value = "Andet"
         .Offset(lCount, 1).Value = dOthers
      End With
      
      'Redimensioner rNewTable til det nye antal rækker
      Set rNewTable = rNewTable.Resize(rNewTable.Rows.Count + 1)
      
      'Variablen med antal rækker opdateres
      lRows = rNewTable.Rows.Count
      
      'Sorter den nye tabel med faldende værdier
      rNewTable.Sort Key1:=rNewTable.Item(2), _
      Order1:=xlDescending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal
   End If
End If

'Redimensionerer arTemp til rNewTables antal rækker
'og 3 kolonner.
ReDim arTemp(1 To lRows, 1 To 3)

'Sætter ranget rFirstCell til første
'celle i rNewTables anden kolonne.
Set rFirstCell = rNewTable.Item(2)

'Redimensionerer rNewTable, så det indeholder
'hele den færdige tabel. Skal bruges, når
'diagrammet skal laves.
Set rNewTable = rNewTable.Resize(lRows, 4)

arTemp(1, 1) = "Akk. %"
'Bemærk apostroffen foran "80 %". Hvis den
'udelades, kan Excel finde på at lave
'formatet om til procent.
arTemp(1, 2) = "'80 %"
arTemp(1, 3) = "Akk. frekvens"

With rFirstCell
   'Akkumuleret % 1. linje
   arTemp(2, 1) = _
   "=" & .Offset(1, 3).Address & _
   "*100/" & .Offset(lRows - 1, 3).Address
   'Til 80 % linjen
   arTemp(2, 2) = 80
   'Akkumuleret frekvens 1. linje
   arTemp(2, 3) = "=" & .Offset(1, 0).Address
   
   'Resten udfyldes med en løkke.
   For lCount = 3 To lRows
      'Akkumuleret procent
      arTemp(lCount, 1) = _
      "=" & .Offset(lCount - 1, 3).Address & _
      "*100/" & .Offset(lRows - 1, 3).Address
      '80 til firsprocentslinjen
      arTemp(lCount, 2) = 80
      'Akkumuleret frekvens
      arTemp(lCount, 3) = _
      "=" & .Offset(lCount - 1, 0).Address & _
      "+" & .Offset(lCount - 2, 3).Address
   Next
End With

'Redefinerer rFirstCell til samme størrelse
'som arrayet arTemp, så vi kan indsætte
'tabelværdierne i ét hug.
Set rFirstCell = rFirstCell.Offset(0, 1)
Set rFirstCell = rFirstCell.Resize(lRows, 3)
'Kopierer formlerne i arTemp til tabelområdet
rFirstCell.Formula = arTemp

'rCell sættes = området med værdier, så vi
'kan formatere tallene.
Set rCell = rFirstCell.Resize(lRows - 1, 4)
Set rCell = rCell.Offset(1, -1)
With rCell
   'Frekvenserne skal ikke have decimaler
   .NumberFormat = "0"
   'Procenterne får 2 decimaler
   .Columns(3).NumberFormat = "#.00"
End With

'Nu skal diagrammet laves. Det sker i
'proceduren 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)
'Denne procedure er næsten som makro-optageren
'lavede den. Jeg har kun ændret et par småting, idet jeg har gjort
'kildetabellens adresse og fanebladets navn til variable.
'Du kan selv more dig med at gøre koden mere
'effektiv, fx ved ikke at vælge, før der
'opereres på objektet.
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 = "Titel"
End With

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