Pareto-diagram i Excel med VBA makroer
På denne side viser jeg, hvordan man nemt og hurtigt kan lave Pareto-diagrammer i Excel med VBA makroer. Kildedata kan være i samme regneark som makroerne eller et andet.
Du kan også downloade et zip-komprimeret regneark med koden, så du kan gå i gang med det samme.
Et Pareto-diagram er et søjlediagram, hvor data er sorteret, så søjlernes højde falder fra venstre mod højre. Over søjlerne er der en kurve, som viser den akkumulerede procent.
Det kan se således ud med nogle fuldstændig fiktive tal for, hvilke undskyldninger folk bruger, når de kommer for sent på arbejde:
Pareto-diagrammer bruges til at visualisere, hvad der vejer tungest - fx fejlkilder i en proces.
Vilfredo Pareto (1848 - 1923) var en italiensk økonom, som fandt ud af, at 20 % af befolkningen ejede 80 % af jorden, og det har lagt navn til Pareto-princippet, men det kan du læse mere om andre steder.
Personligt har jeg ikke svært ved at spotte de højeste søjler, selvom de ikke står til venstre, men bl.a. Lean Six Sigma har gjort Pareto-diagrammer populære, og hvis det er dem, man vil have, skal de laves så nemt som muligt.
Makroerne herunder gør følgende:
- Beder brugeren udpege inputværdierne. Det kan være i samme regneark eller et andet, og værdierne kan stå i en kolonne eller en række.
- Beder brugeren udpege, hvor den sorterede tabel skal indsættes. Tabellen skal sorteres, for at få de højeste søjler til venstre.
- Hvis flere poster tilsammen udgør mindre end 5 %, får brugeren mulighed for at slå dem sammen i én post kaldet "Andet".
- Derefter sorteres tabellen, og pareto-diagrammet indsættes.
- Undervejs er der selvfølgelig kontrol af, om inputværdier m.v. er valide, og det kontrolleres også, om den sorterede tabel vil overlappe tabellen med inputværdier.
Du kan kopiere koden herunder til et VBA-modul i Excel, hvor du også laver en simpel Userform med en label til tekst og to command buttons til "OK" og "Cancel". Alternativt kan du downloade regnearket med koden fiks og færdig.
De følgende makroer bruger bl.a.:
- En modeless ("flydende") Userform
- Brugerudpegede ranges
- Dynamiske ranges
- Arrays
- Kopiering fra range til array og vice versa
- Application.Intersect for at afgøre, om områder overlapper hinanden
- Løkker
Hvis du selv vil, så start med at lave en userform med en label og to kommandoknapper. I mit eksempel hedder formularen "frmSelect," OK-knappen "cmdOK" og Cancel-knappen "cmdCancel". Formularens kode følger her:
Private Sub UserForm_Initialize()
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
Private Sub cmdOK_Click()
Unload Me
If bInput Then
Module1.Analyze
Else
Module1.MakeTable
End If
End Sub
Private Sub cmdCancel_Click()
Unload Me
ThisWorkbook.Activate
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then cmdCancel_Click
End Sub
Det var vores Userform, nu følger koden, som skal ligge i Module1. Vi starter med de variabler, som deklareres på modul-niveau, altså øverst.
Option Explicit
Public bAbort As Boolean
Public bInput As Boolean
Dim bVertical As Boolean
Public lRows As Long
Dim sHeader As String
Dim sLabelHead As String
Dim rCell As Range
Dim rInput As Range
Dim rLabels As Range
Dim rTotInput As Range
Dim arTable
Og nu følger proceduren, som starter det hele.
Sub Start()
On Error GoTo ErrorHandle
bAbort = False
bVertical = False
sHeader = ""
sLabelHead = ""
bInput = True
frmSelect.Show vbModeless
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Start"
End Sub
Når brugeren har valgt inputområde og klikket OK, kalder formularens OK-knap følgende procedure, som tjekker, om inputværdierne er OK.
Sub Analyze()
On Error GoTo ErrorHandle
Set rInput = Selection
If rInput.Count = 1 Then
MsgBox "Du har kun valgt 1 celle. Prøv igen!"
bAbort = True
GoTo BeforeExit
End If
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
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
If .Columns.Count > 1 Then
MsgBox "Du har valgt mere end 1 kolonne"
ThisWorkbook.Activate
GoTo BeforeExit
End If
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 = _
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
MsgBox "Ved værdier i en række, " & _
"skal kategorierne stå i rækken ovenover."
GoTo BeforeExit
End If
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
lRows = rInput.Count + 1
bInput = False
frmSelect.Show vbModeless
BeforeExit:
On Error Resume Next
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure Analyze"
bAbort = True
Resume BeforeExit
End Sub
Hvis vi kom hertil, var inputværdierne valide, og nu skal tabellen til Pareto-diagrammet laves. Brugeren udpeger (adspurgt af frmSelect), hvor øverste venstre celle skal sættes ind, og når han trykker "OK," kaldes proceduren MakeTable.
Sub MakeTable()
Dim lCount As Long
Dim lLow As Long
Dim dOthers As Double
Dim dPct As Double
Dim dSum As Double
Dim sAddress As String
Dim rFirstCell As Range
Dim rNewTable As Range
Dim vInput
Dim arTemp()
Dim arPct()
On Error GoTo ErrorHandle
Application.ScreenUpdating = False
Set rFirstCell = Selection
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
If rFirstCell.Count > 1 Then
Set rFirstCell = rFirstCell.Item(1)
End If
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
Set rNewTable = Range(rFirstCell, rFirstCell.Offset(lRows - 1, 1))
rNewTable.Sort Key1:=rNewTable.Item(2), _
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
dSum = WorksheetFunction.Sum(rInput)
arTemp = rNewTable.Value
ReDim arPct(1 To UBound(arTemp))
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 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")
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
Set rNewTable = rNewTable.Resize(rNewTable.Rows.Count + 1)
lRows = rNewTable.Rows.Count
rNewTable.Sort Key1:=rNewTable.Item(2), _
Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End If
End If
ReDim arTemp(1 To lRows, 1 To 3)
Set rFirstCell = rNewTable.Item(2)
Set rNewTable = rNewTable.Resize(lRows, 4)
arTemp(1, 1) = "Akk. %"
arTemp(1, 2) = "'80 %"
arTemp(1, 3) = "Akk. frekvens"
With rFirstCell
arTemp(2, 1) = _
"=" & .Offset(1, 3).Address & _
"*100/" & .Offset(lRows - 1, 3).Address
arTemp(2, 2) = 80
arTemp(2, 3) = "=" & .Offset(1, 0).Address
For lCount = 3 To lRows
arTemp(lCount, 1) = _
"=" & .Offset(lCount - 1, 3).Address & _
"*100/" & .Offset(lRows - 1, 3).Address
arTemp(lCount, 2) = 80
arTemp(lCount, 3) = _
"=" & .Offset(lCount - 1, 0).Address & _
"+" & .Offset(lCount - 2, 3).Address
Next
End With
Set rFirstCell = rFirstCell.Offset(0, 1)
Set rFirstCell = rFirstCell.Resize(lRows, 3)
rFirstCell.Formula = arTemp
Set rCell = rFirstCell.Resize(lRows - 1, 4)
Set rCell = rCell.Offset(1, -1)
With rCell
.NumberFormat = "0"
.Columns(3).NumberFormat = "#.00"
End With
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
Nu udestår kun at lave selve diagrammet.
Sub MakeParetoChart(ByVal rTable As Range)
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
Der skulle en del kode til, men nu kan du lave Pareto-diagrammer i en ruf, og det være sig i samme regneark eller andre. Vil du have diagrammet til at se anderledes ud, må du selv i gang, og du kan evt. slå makrooptageren til.
Relateret:
|