Median Value for Data using VBA-Macro

Thank you Abinash for coming up with a new challenge and thus something new to learn :)

I started solving it today, used references from google, applied certain code basics and was able to get the desired output.

Requirement:

With ref to example sheet as indicated in (Snapshot 1) which stores the list of class, names of students and their ages. Create an additional field which should hold the median value of the ages grouped by class. Basically with change in the filter, when the ages are displayed as per the filtered rows, the median of the visible ages should also change.

Snapshot 1: Understanding the requirement

Snapshot-2: Knowing the solution frame-work

Snapshot-3: Observation of the result

1. click of the button Cal Median to get the desired result

2. Del CAL is used to delete the calculation and create chart.

The two buttons are added using Toolbox and are assigned macros MedianPT() and del_Chart() respectively.

Macro-code:

'---------------------------------------------------------------------------------------

'Calculation of Median (Class-wise) for a list of students

'Pivottable name -> Pivottable1

'Data in sheet "Data" name-> Table2 (It's a table and not a range)

'Result is populated in TABLE named -> Table1

'---------------------------------------------------------------------------------------

Option Explicit
Sub MedianPT()

Dim n As Integer, i As Integer, p As Integer, dt_total As Integer

Dim sr As Integer, k As Integer, j As Integer

Dim m As Single

Dim a As Variant, b As Variant, ps As Variant

Dim st As Range

Dim nn As PivotItem, pivt As PivotItem
k = 1

i = 1

p = 1

On Error GoTo 0

Application.ScreenUpdating = False
Sheets("Data").Activate

With Sheets("Data")

With .Range("Table2")

dt_total = .Rows.Count

End With
Sheets("Pivot").Activate

With ActiveSheet.PivotTables("PivotTable1")

.PivotCache.Refresh

.PivotCache.MissingItemsLimit = xlMissingItemsNone

sr = .PivotFields("Class").PivotItems.Count

ReDim ps(sr)

For n = 1 To sr

Set pivt = .PivotFields("Class").PivotItems(n)

If pivt.Visible = True Then

ps(k) = pivt.Name

k = k + 1

End If

Next n
ReDim a(dt_total, k - 1)
End With
With ActiveSheet.ListObjects("Table1") ' delete Previous Content

.ListColumns(2).DataBodyRange.ClearContents

.Range.RemoveDuplicates Columns:=2, Header:=xlYes

.ListRows(1).Range.ClearContents

.Resize .Range.Resize(sr)

.Resize .Range.Resize(k + 1)

For n = 1 To k - 1

.ListColumns(1).DataBodyRange.Cells(n) = ps(n)

Next n

End With
With ActiveSheet.PivotTables("PivotTable1")

On Error GoTo errDo

For j = 1 To k - 1

For Each nn In .PivotFields("Name").PivotItems

a(i, p) = .GetPivotData("_Age", "Class", ps(j), "Name", nn)

i = i + 1

Next nn

ReDim b(i)

For n = 1 To i - 1

b(n) = a(n, p)

Next n

m = Application.WorksheetFunction.Average(b)

Sheets("Pivot").Range("Table1[Avg_Age]").Cells(p) = m

m = Application.WorksheetFunction.Median(b)

Sheets("Pivot").Range("Table1[Md_Age]").Cells(p) = m

p = p + 1

i = 1

Next j

End With
On Error GoTo 0 'reset

m = Application.WorksheetFunction.Average(a)

ActiveSheet.ListObjects("Table1").ShowTotals = True

Range("Table1[[#Totals],[Avg_Age]]").Select

Range("Table1[[#Totals],[Avg_Age]]").Formula = "=" & m

Range("Table1[[#Totals],[Avg_Age]]").Select

m = Application.WorksheetFunction.Median(a)

Range("Table1[[#Totals],[Md_Age]]").Formula = "=" & m

End With

ActiveSheet.Shapes.AddChart.Select

ActiveChart.SetSourceData Source:=Range("Pivot!Table1")

ActiveChart.ChartType = xlLineMarkersStacked

Range("A1").Select

Exit Sub

errDo: i = i - 1
Resume Next
End Sub

Sub del_Chart()

Dim ch

ActiveSheet.ListObjects("Table1").ShowTotals = False

If ActiveSheet.ChartObjects.Count <> 0 Then

For Each ch In ActiveSheet.ChartObjects

ActiveSheet.ChartObjects.Delete

Next

Else

MsgBox "No Chart !!"

End If

With ActiveSheet.ListObjects("Table1")

.ListColumns(2).DataBodyRange.ClearContents

.Range.RemoveDuplicates Columns:=2, Header:=xlYes

.ListRows(1).Range.ClearContents

End With

End Sub

Please check the SnapShot for the data that I have: