This is a rudimentary (and not thoroughly checked) graphical representation
of data as a boxplot. It does not check the outliers using Grubb's test
however shows outliers that are farther than 1.5 IQR.
Looking for ideas on improving it.
Copy and paste the code into a new module and run the macro
Calculate_BoxPlot
--
Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To post to this group, send email to excel-macros@googlegroups.com.
To unsubscribe from this group, send email to
excel-macros+unsubscr...@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros?hl=en.
Sub Calculate_BoxPlot()
Dim sLW As Single, s1Q As Single, sM As Single, s3Q As Single, sUW As Single,
sPE As Single, sME As Single
Dim iMinA As Integer, iMaxA As Integer 'minimum and maximum values for the
graph axis
Dim sMin As Single, sMax As Single, sIQR As Single, sRange As Single
Dim iSht As Integer
Dim sSht_n As String, sSht_o As String ' new sheet, old sheet
Dim lLastRow As Long, lRowCount As Long
Dim iLastCol As Integer, iColCount As Integer
Dim rCell As Range, rRng As Range
Dim j As Long
Dim i As Integer
Dim k As Long, maxK As Long
'sLW = Lower Wisker
's1Q = 1st Quartile
'sM = Median
's3Q = 3rd Quartile
'sUW = Upper Wisker
'iMinA = minimum for Axis
'iMaxA = maximum for Axis
'sMin = Minimum Value no farther than 1.5 * IQR
'sMax = Maximum Value no farther than 1.5 * IQR
'sIQR = Inter Quartile Range (3rd Quartile - 1st Quartile)
'sRange = real range = maximum value - minimum value regardless of IQR
'check if anything selected
If Application.WorksheetFunction.CountA(Selection) < 5 Then
MsgBox "Error! You need at least 5 rows of data plus the title of the
column", vbCritical
Exit Sub
End If
'add Temporary Sheet
sSht_o = ActiveSheet.Name
iSht = Sheets.Count
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(iSht + 1).Select
sSht_n = tmpSheet
Sheets(iSht + 1).Name = sSht_n
'copy data range into tmpSheet
Sheets(sSht_o).Activate
Selection.Copy
Sheets(sSht_n).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
'check data integrity (all numbers)
lLastRow = ActiveSheet.UsedRange.Rows.Count
iLastCol = ActiveSheet.UsedRange.Columns.Count
iColCount = iLastCol
For i = 1 To iColCount
Columns(i).Select
Selection.End(xlDown).Select
lRowCount = ActiveCell.Row
For j = 2 To lRowCount
If Not IsNumeric(Cells(j, i)) Then
MsgBox "Error! All data (except column titles) must be numeric.
You have non numeric cells", vbCritical
Sheets(sSht_o).Activate
Application.DisplayAlerts = False
Sheets(sSht_n).Delete
Application.DisplayAlerts = True
Exit Sub
End If
Next
Next
'prepare sheet for calculation
Range(Cells(1, 1), Cells(1, iLastCol)).Select
Selection.Copy
Cells(1, iLastCol + 3).Select
ActiveSheet.Paste
Cells(2, iLastCol + 2) = "3rd Quartile"
Cells(3, iLastCol + 2) = "Median"
Cells(4, iLastCol + 2) = "1st Quartile"
Cells(5, iLastCol + 2) = "Lower Wisker"
Cells(6, iLastCol + 2) = "Upper Wisker"
Cells(7, iLastCol + 2) = "Box Range"
Cells(8, iLastCol + 2) = "Plus Error"
Cells(9, iLastCol + 2) = "Minus Error"
Cells(11, iLastCol + 2) = "Min Axis"
Cells(12, iLastCol + 2) = "Max Axis"
Cells(1, iLastCol + 2).Select
For i = 1 To iColCount + 1
Columns(iLastCol + 1 + i).Select
Columns(iLastCol + 1 + i).EntireColumn.AutoFit
Next
'start calculation
iMinA = 1
iMaxA = 0
For i = 1 To iColCount
Columns(i).Select
Selection.End(xlDown).Select
lRowCount = ActiveCell.Row
Cells(5, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=MIN(R[-3]C[-" & iLastCol + 2 & "]:R[" &
lRowCount - 5 & "]C[-" & iLastCol + 2 & "])"
Cells(4, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=QUARTILE.EXC(R[-2]C[-" & iLastCol + 2 &
"]:R[" & lRowCount - 4 & "]C[-" & iLastCol + 2 & "],1)"
Cells(3, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=MEDIAN(R[-1]C[-" & iLastCol + 2 & "]:R[" &
lRowCount - 3 & "]C[-" & iLastCol + 2 & "])"
Cells(2, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=QUARTILE.EXC(RC[-" & iLastCol + 2 & "]:R[" &
lRowCount - 2 & "]C[-" & iLastCol + 2 & "],3)"
Cells(6, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=Max(R[-4]C[-" & iLastCol + 2 & "]:R[" &
lRowCount - 6 & "]C[-" & iLastCol + 2 & "])"
Cells(7, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=R[-5]C-R[-3]C"
Cells(8, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=R[-2]C-R[-6]C"
Cells(9, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=R[-5]C-R[-4]C"
Cells(11, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=ROUNDDOWN(MIN(R[-6]C:R[-6]C[2]),0)"
If iMinA > iMaxA Then iMinA = ActiveCell.Value
If iMinA > ActiveCell.Value Then iMinA = ActiveCell.Value
Cells(12, iLastCol + 2 + i).Select
ActiveCell.FormulaR1C1 = "=ROUNDUP(MAX(R[-6]C:R[-6]C[2]),0)"
If iMaxA < iMinA Then iMaxA = ActiveCell.Value
If iMaxA < ActiveCell.Value Then iMaxA = ActiveCell.Value
Cells(1, iLastCol + 2 + i).Select
Next
Range(Cells(11, iLastCol + 2 + 1), Cells(12, iLastCol + 2 +
iColCount)).Select
Selection.Clear
Cells(11, iLastCol + 3) = iMinA
Cells(12, iLastCol + 3) = iMaxA
Cells(1, iLastCol + 2).Select
maxK = Outliers(lLastRow, iLastCol)
'plot the data
ActiveSheet.Shapes.AddChart.Select
ActiveSheet.Shapes("Chart 1").IncrementTop 70
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range(sSht_n & "!$" & Chr(iLastCol + 2 +
64) & "$1:$" & Chr(iLastCol + 2 + iColCount + 64) & "$4"), PlotBy:=xlRows
ActiveChart.PlotArea.Select
'ActiveChart.SetSourceData
'ActiveChart.SeriesCollection(4).Select
ActiveChart.SetElement (msoElementErrorBarStandardError)
ActiveChart.SeriesCollection(2).ErrorBars.Select
ActiveChart.SetElement (msoElementErrorBarNone)
ActiveChart.SeriesCollection(1).ErrorBars.Select
ActiveChart.SeriesCollection(1).ErrorBar Direction:=xlY, Include:= _
xlPlusValues, Type:=xlStError
ActiveChart.SeriesCollection(1).ErrorBar Direction:=xlY, Include:= _
xlPlusValues, Type:=xlCustom, amount:=Worksheets(sSht_n).Range(Cells(8,
iLastCol + 3), Cells(8, iLastCol + 2 + iColCount))
ActiveChart.SeriesCollection(3).Select
ActiveChart.SetElement (msoElementErrorBarStandardError)
ActiveChart.SeriesCollection(3).ErrorBars.Select
ActiveChart.SeriesCollection(3).ErrorBar Direction:=xlY, Include:= _
xlMinusValues, Type:=xlStError
ActiveChart.SeriesCollection(3).ErrorBar Direction:=xlY, Include:= _
xlMinusValues, Type:=xlCustom, amount:=0,
minusvalues:=Worksheets(sSht_n).Range(Cells(9, iLastCol + 3), Cells(9, iLastCol
+ 2 + iColCount))
ActiveChart.PlotArea.Select
'ActiveChart.SeriesCollection(1).Delete
'ActiveChart.SeriesCollection(4).Delete
'ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(2).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveChart.SeriesCollection(2).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Solid
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.349999994
.Transparency = 0
.Solid
End With
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(3).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Solid
End With
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.349999994
.Transparency = 0
.Solid
End With
Selection.Format.Line.Visible = msoFalse
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(3).Select
ActiveChart.ChartGroups(1).GapWidth = 264
ActiveChart.ChartGroups(1).Overlap = 100
ActiveChart.PlotArea.Select
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.Shapes("Chart 1").ScaleWidth 1.5, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.Shapes("Chart 1").ScaleHeight 1.5, msoFalse, _
msoScaleFromTopLeft
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.Axes(xlValue).MajorGridlines.Select
Selection.Format.Line.Visible = msoFalse
ActiveChart.SetElement (msoElementLegendNone)
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MinimumScale = Cells(11, iLastCol + 3).Value
ActiveChart.Axes(xlValue).MaximumScale = Cells(12, iLastCol + 3).Value
'count the max number of outliers for each column
For k = 14 To maxK
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection.NewSeries
ActiveChart.SeriesCollection(4 + k - 14).Name = "Outliers"
ActiveChart.SeriesCollection(4 + k - 14).Values = sSht_n & "!$" &
Chr(iLastCol + 3 + 64) & "$" & k & ":$" & Chr(iLastCol + 2 + iColCount + 64) &
"$" & k
ActiveChart.SeriesCollection(4 + k - 14).Select
ActiveChart.SeriesCollection(4 + k - 14).ChartType = xlXYScatter
ActiveChart.SeriesCollection(4 + k - 14).Select
Selection.MarkerStyle = -4168
With Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(128, 128, 128)
.BackColor.RGB = RGB(255, 255, 255)
End With
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
End With
Next
Range("A1").Select
End Sub
Function tmpSheet() As String
Dim sLetter(8) As String, sName As String
Dim iLetterType As Integer
Dim i As Integer
sName = ""
For i = 0 To 7
iLetterType = WorksheetFunction.RandBetween(1, 3)
Select Case iLetterType
Case 1
sLetter(i) = Chr(WorksheetFunction.RandBetween(65, 90))
Case 2
sLetter(i) = Chr(WorksheetFunction.RandBetween(97, 122))
Case 3
sLetter(i) = Chr(WorksheetFunction.RandBetween(48, 57))
End Select
sName = sName & sLetter(i)
Next
tmpSheet = sName
End Function
Function Outliers(lRow As Long, iCol As Integer) As Long
Dim i As Integer 'columns
Dim j As Long 'rows
Dim k As Long 'outlier row
Dim iColCount As Integer
Dim sOutlier As Single
Dim sRange As Single
Dim maxK As Long
iColCount = iCol + 3
Cells(14, iColCount - 1) = "Outliers"
maxK = 14
For j = 1 To iCol
k = 14
sRange = Cells(7, j + iColCount - 1)
For i = 2 To lRow
If Cells(i, j) <> "" Then
If Cells(i, j) < Cells(3, j + iColCount - 1) Then
sOutlier = Cells(4, j + iColCount - 1) - Cells(i, j)
If sOutlier > sRange * 1.5 Then
Cells(k, j + iColCount - 1) = Cells(i, j)
Cells(i, j) = ""
k = k + 1
End If
Else
sOutlier = Cells(i, j) - Cells(2, j + iColCount - 1)
If sOutlier > sRange * 1.5 Then
Cells(k, j + iColCount - 1) = Cells(i, j)
Cells(i, j) = ""
k = k + 1
End If
End If
End If
Next
If maxK < k - 1 Then maxK = k - 1
Next
Outliers = maxK
End Function
