[英]Excel Pivot tables and Percentiles/Quartiles/Medians
在我的工作中，经常出现的一件事是需要对数据集执行中位数，四分位数和百分位数运算。 我也不得不使用excel（不是我的选择），并且出于功能原因（'dem slicers，hot damn），我也不得不使用数据透视表。
Excel（至少Excel 2010）在其数据透视表中没有此功能。 某些组件（例如Power Pivot）显然添加了此功能 ，但并非每个人都有可以在任何时候安装的工作环境。 还有一些其他值得注意的解决方法：
这些变通办法很好，但是当我有100,000行以上的数据时，它开始花一些时间在我的烤面包机上工作-我想要数据透视表的全部原因是，我可以拥有一个漂亮的切片机驱动的仪表板和反应迅速。 同样重要的是，即使工作表最多可以容纳100万行数据，使用Excel的条件和公式也会在超过65k +数据点时破解它。
因此，基本上，我想要一种可靠且可靠的方法来为数据透视表中的给定选定变量计算百分位数数据，并且我希望它不会以冰冷的速度前进。 我也希望它在数据子类别为> 65K行时起作用。
我的解决方案是用VBA编码的。 此答案将分为两部分：
用（几乎）一句话 ：我的方法是将数据透视表作为目标，在数据透视表旁边创建一个适当大小的范围，然后使用目标值列向下钻取数据透视表以仅查看该数据的子类别-从此处为百分比数据是通过QUICKSELECT算法计算的，并粘贴到指定的范围内，并且清除/删除了向下钻取的数据表。 然后洗净； 冲洗; 重复。
用不止一个句子：
我们的主要功能（ FindPivotPercentiles ）将以下各项作为输入： target Pivot Table ，value列的标题字符串以计算其值，以及可选地要计算的百分位数 。
我们通过调用PivotEdgeRange函数找到结果输出范围，以放置计算出的百分位数，该函数将获取目标数据透视表（用于计算输出范围的垂直范围）和百分位数（用于计算范围的水平扩展-因此如果一个10类长度的数据透视表计算出0.25，.5和.75个百分位数，则会在数据透视表的右侧返回一个3 x 10目标范围）。
我们还将数据透视表中的最后一个值列设置为目标列，这仅用于向下钻取数据，选择的实际值并不重要，只要适当地选择了类别即可。
然后，我们遍历数据列范围内的行，调用函数PivotPercentiles 。 该函数是实际钻取到数据透视表中的位，其中包含调用函数提供的目标单元格以及我们希望为其计算的实际值的标题字符串。 使用targetCell.ShowDetail = True进行向下钻取，Excel创建的工作表将由子例程autoRenamePivotDetail自动重命名（我想这不是绝对必要的，但是我发现这些东西并不是很明确）屁股以后）。 从较早提供的标题字符串中选择此向下钻取数据中的目标数据列，并将其循环以创建数组。
使用QUICKSELECT算法从数组（ QuickSelect，QSPartition QSSwapElems ）中计算所需的百分位数值，该算法与QUICKSORT类似， 不同之处在于，当确定找到第k个值时，它将停止。
一旦返回了数据透视表中该行的百分位值数组，就不再需要向下钻取数据表并将其删除。 将百分位数返回到顶级调用函数，以粘贴到FindPivotPercentiles函数中确定的“结果范围”中，然后对下一个可用数据行重复该过程，直到用尽所有数据。
最后，然后完成所有这些操作，找到结果范围和实际数据透视表的范围的并集，并给定名称，以便每次使用切片器更改显示的数据透视表数据时，命名范围为动态更新，因此任何依赖项/图形也将更新。
输出看起来像这样：
在此示例中，红色范围是用于向下钻取的目标列（但不一定是用于计算的实际目标数据），绿色是结果范围，蓝色是输出命名范围，供用户稍后使用
Sub FindPivotPercentiles(ByRef targetWorksheet As Worksheet, _
ByRef targetPivot As PivotTable, _
ByRef columnToCalc As String, _
Optional ByRef percentInputs As Variant = -1)
'**********************************************************
'** Finds all Percentile Data for a given pivot table **
'**********************************************************
Dim valueTitle As String ' detail sheet column title to calc values from
Dim targetColumn As Range ' Range of above column
Dim resultColumn As Range ' output range for percentile values
Dim wholePivotRange As Range ' selects entire pivot for naming range
Dim percentiles() As Single ' desired percentile levels to calculate
Dim j As Long ' iterator
Dim k As Long ' iterator
' ------------------------------------------------------------------------------------
' User selectable things, choose the column to calculate percentiles for (eg "DAP")
' ------------------------------------------------------------------------------------
valueTitle = columnToCalc
' ------------------------------------------------------------------------------------
' Initalize the percentile array with default values if no user specified option present
' ------------------------------------------------------------------------------------
If IsArray(percentInputs) = False Then
If percentInputs = -1 Then
ReDim percentiles(1 To 7) As Single
percentiles(1) = 0#
percentiles(2) = 0.1
percentiles(3) = 0.25
percentiles(4) = 0.5
percentiles(5) = 0.75
percentiles(6) = 0.9
percentiles(7) = 1#
End If
Else
' ------ otherwise make them the input values
ReDim percentiles(1 To UBound(percentInputs) - LBound(percentInputs) + 1) As Single
For j = 1 To UBound(percentInputs) - LBound(percentInputs) + 1
percentiles(j) = percentInputs(j - (1 - LBound(percentInputs)))
Next j
End If
Set resultColumn = PivotEdgeRange(targetWorksheet, targetPivot, percentiles)
Set targetColumn = targetPivot.DataBodyRange.Resize(, 1)
' ------------------------------------------------------------------------------------
' Clean up work area, create some percentile headers and appropriately format then,
' then calculate percentile values and paste in area to right of pivot table
' ------------------------------------------------------------------------------------
resultColumn.Resize(, 100).EntireColumn.Clear
targetColumn.Resize(1).Offset(-1, 0).Copy
resultColumn.Resize(1).Offset(-1, 0).PasteSpecial xlPasteFormats
resultColumn.Resize(1).Offset(-1, 0) = percentiles
For j = 1 To targetColumn.Rows.count
resultColumn.Rows(j) = PivotPercentiles(targetColumn.Rows(j), targetWorksheet, valueTitle, percentiles, True)
Debug.Print "calculating row: " & j
Next j
' ------ format nicely, name range for later use
With resultColumn
.NumberFormat = "0.00"
Set resultColumn = .Resize(.Rows.count + 1).Offset(-1, 0)
.Name = valueTitle & "_Percents"
End With
Set wholePivotRange = targetPivot.TableRange1
Set wholePivotRange = Union(wholePivotRange, resultColumn)
wholePivotRange.Name = valueTitle & "_WholeTable"
End Sub
Function PivotEdgeRange(ByRef targetWorksheet As Worksheet, _
ByRef targetPivot As PivotTable, _
Optional ByRef percentInputs As Variant = -1) As Range
'*************************************************************************
'** For a given pivot table, set a range to the right most empty column **
'*************************************************************************
Dim numDataCols As Long ' number of value fields in table
Dim howManyOutputColumns As Integer ' how many percentile calculation cols
If IsArray(percentInputs) = False Then
If percentInputs = -1 Then: howManyOutputColumns = 7
Else
howManyOutputColumns = UBound(percentInputs)
End If
numDataCols = targetPivot.DataBodyRange.Columns.count
Set PivotEdgeRange = targetPivot.DataBodyRange.Resize(, howManyOutputColumns).Offset(, numDataCols)
End Function
Function PivotPercentiles(ByRef targetCell As Range, _
ByRef pivotCacheSheet As Worksheet, _
ByRef valueTitle As String, _
Optional ByRef percentInputs As Variant = -1, _
Optional ByRef suppressErrors As Boolean = False) As Double()
'************************************************************************
'** Finds the Percentile Data for a given grouping in a pivot table **
'************************************************************************
Dim targetColumn As Range ' targetColumn for calculation
Dim numberOfVals As Long ' number of values, used to determine array size
Dim j As Long ' iterator
Dim badData As Boolean ' flags that non-numeric data was in target column
Dim range2Array() As Double ' coverts target range to array for faster calculation
Dim percentiles() As Single ' desired percentile levels to calculate
Dim percentOutputs() As Double ' holds calculated percentiles
Dim targetkth As Long ' kth smallest value to extract from quickselect
' ------------------------------------------------------------------------------------
' Initalize the percentile array with default values if no user specified option
' present. This is already done in FindPivotPercentiles, so is mostly redundant, but
' I have left this in so you may have the option of using this as a stand alone function
' ------------------------------------------------------------------------------------
If IsArray(percentInputs) = False Then
If percentInputs = -1 Then
ReDim percentiles(1 To 7) As Single
percentiles(1) = 0#
percentiles(2) = 0.1
percentiles(3) = 0.25
percentiles(4) = 0.5
percentiles(5) = 0.75
percentiles(6) = 0.9
percentiles(7) = 1#
End If
Else
' ------ otherwise make them the input values
ReDim percentiles(1 To UBound(percentInputs) - LBound(percentInputs) + 1) As Single
For j = 1 To UBound(percentInputs) - LBound(percentInputs) + 1
percentiles(j) = percentInputs(j - (1 - LBound(percentInputs)))
Next j
End If
ReDim percentOutputs(1 To UBound(percentiles)) As Double
' ------------------------------------------------------------------------------------
' Show detail in target cell so we can compute the percentile data values. Show detail
' creates a new sheet with name "Sheet*" - we switch to this, and compute the medians
' in this space, before deleting it.
' ------------------------------------------------------------------------------------
targetCell.ShowDetail = True
Call autoRenamePivotDetail
Set pivotCacheSheet = ThisWorkbook.Sheets("PivotDetail")
Set targetColumn = pivotCacheSheet.ListObjects(1).ListColumns(valueTitle).DataBodyRange
numberOfVals = targetColumn.Rows.count
' ----- convert range to array, quicker computation time
ReDim range2Array(1 To numberOfVals) As Double
For j = 1 To targetColumn.Rows.count
Select Case VarType(targetColumn(j))
Case 2 To 4
range2Array(j) = CDbl(targetColumn(j))
Case 5
range2Array(j) = targetColumn(j)
Case 8
range2Array(j) = CDbl(targetColumn(j))
Case Else
range2Array(j) = Empty
badData = True
End Select
Next j
' ------------------------------------------------------------------------------------
' Now we have an array to play with, loop over desired percentile values and calculate
' If arrays are no larger than 10, the .Percentile_Inc function can be used instead -
' this is neccessary as QuickSelect breaks when less than 3 array size.
' ------------------------------------------------------------------------------------
For j = 1 To UBound(percentiles)
If UBound(range2Array) < 10 Then
percentOutputs(j) = Application.WorksheetFunction.Percentile_Inc(range2Array, percentiles(j))
Else
targetkth = percentiles(j) * UBound(range2Array)
If targetkth = 0 Then: targetkth = 1
percentOutputs(j) = QuickSelect(range2Array, targetkth, 1, UBound(range2Array))
End If
Next j
' ------ clean up
Application.DisplayAlerts = False
pivotCacheSheet.Delete
Application.DisplayAlerts = True
If badData And suppressErrors <> True Then
MsgBox "Bad data (non-numeric) was found in the target range. Please ensure better cleaning of input data."
End If
' ----- output values to calling function
PivotPercentiles = percentOutputs
End Function
Sub autoRenamePivotDetail()
'*****************************************************************************
'** Automatically rename the newly created detailed pivot data. This **
'** relies on all worksheets otherwise having sensible names, it will ruin **
'** your sheet names otherwise **
'*****************************************************************************
Dim detailedPivotFound As Boolean ' True if pivot detail sheet found
Dim wSheet As Worksheet ' Worksheet iterator
Dim renameSheet As Worksheet ' Sheet to actually rename
detailedPivotFound = False
If CheckPresent("PivotDetail", "Worksheet") Then
Err.Raise Number:=2000, _
Source:="AlreadyPresent", _
Description:="Cannot rename worksheet; 'PivotDetail sheet already present"
End If
' ------ cycle through, change name to pivotsheet
For Each wSheet In ThisWorkbook.Worksheets
If wSheet.Name Like "Sheet*" And detailedPivotFound = True Then
Err.Raise Number:=2000, _
Source:="AlreadyPresent", _
Description:="Cannot expand pivot detail; spare 'sheet' name already present."
End If
If wSheet.Name Like "Sheet*" Then
detailedPivotFound = True
Set renameSheet = wSheet
End If
Next wSheet
renameSheet.Name = "PivotDetail"
' ------------------------------------------------------------------------------------
' Error handling for cases which do not have a CheckPresent datatype defined for them
' as of yet, or if multiple "sheet*" names are found
' ------------------------------------------------------------------------------------
AlreadyPresent_End:
Exit Sub
AlreadyPresent_Err:
MsgBox Prompt:="Error number " & Err.Number & " was raised. " & _
vbCrLf & "Source: " & Err.Source & vbCrLf & _
"Description: " & Err.Description
Resume AlreadyPresent_End
End Sub
Function QuickSelect(list() As Double, k As Long, startInterval As Long, endInterval As Long) As Double
'**********************************************************************
'** Uses a partial form of QUICKSELECT to find k'th percentile value **
'**********************************************************************
Dim pivotInterval As Long ' where the current pivotpoint is
Dim splitInterval As Long ' where to split the interval
Dim notFinished As Boolean: notFinished = True ' flips to true once kth val found
' ------------------------------------------------------------------------------------
' Adapted from:
' https://stackoverflow.com/questions/3779763/fast-algorithm-for-computing-percentiles-to-remove-outliers
' More information on the QuickSelect algorithm: https://en.wikipedia.org/wiki/Quickselect
' ------------------------------------------------------------------------------------
While notFinished
pivotInterval = CLng(Floor(startInterval + endInterval) / 2)
' ------ make sure min and max cases handled properly
If k = 1 Then pivotInterval = CLng(Floor(startInterval + endInterval) / 2)
If k = endInterval Then pivotInterval = CLng(Ceiling(startInterval + endInterval) / 2)
splitInterval = QSPartition(list, startInterval, endInterval, pivotInterval)
If k < splitInterval Then
endInterval = splitInterval
ElseIf k > splitInterval Then
startInterval = splitInterval + 1
Else
QuickSelect = list(k)
notFinished = False
End If
' ------ break loop for max case.
If k = startInterval And k = endInterval Then
QuickSelect = list(k)
notFinished = False
End If
Wend
End Function
Function QSPartition(list() As Double, startInterval As Long, endInterval As Long, _
pivotInterval As Long) As Long
'**********************************************************
'** Swaps higher and lower elements within the partition **
'**********************************************************
Dim pivotValue As Double ' the value of the pivot point
Dim newPivot As Double ' the new pivot point after partitioning
Dim storeInterval As Double ' temp value to help swapping pivot value
Dim i As Double ' iterator
pivotValue = list(pivotInterval)
list(pivotInterval) = list(startInterval)
list(startInterval) = pivotValue
storeInterval = startInterval + 1
While (storeInterval < endInterval) And list(storeInterval) <= pivotValue
storeInterval = storeInterval + 1
Wend
For i = storeInterval + 1 To endInterval
If list(i) <= pivotValue Then
Call QSSwapElems(list, i, storeInterval)
storeInterval = storeInterval + 1
End If
Next i
newPivot = storeInterval - 1
list(startInterval) = list(newPivot)
list(newPivot) = pivotValue
QSPartition = newPivot
End Function
Sub QSSwapElems(ByRef list() As Double, ByVal i As Long, ByVal j As Long)
'************************
'** Swap list elements **
'************************
Dim temp As Double
temp = list(i)
list(i) = list(j)
list(j) = temp
End Sub
Function CheckPresent(checkName As String, checkType As String) As Boolean
'*******************************************************************
'** Checks that <checkname> is present in object type <checktype> **
'*******************************************************************
Dim index As Long ' iterator
CheckPresent = False
index = 1
Select Case checkType
Case "Connections"
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' Find whether a given named Connection exists
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Dim conName As Connections
Dim conParent As Variant
Set conParent = ThisWorkbook.Connections
While (CheckPresent <> True And index <= conParent.count)
If conParent(index).Name = checkName Then: CheckPresent = True
index = index + 1
Wend
Case "Worksheet"
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' Find whether a given named worksheet exists
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Dim wName As Worksheet
Dim sheetParents As Sheets
Set sheetParents = ThisWorkbook.Worksheets
While (CheckPresent <> True And index <= sheetParents.count)
If sheetParents(index).Name = checkName Then: CheckPresent = True
index = index + 1
Wend
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' handle cases where no data type exists,
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Case Else
Err.Raise Number:=vbObjectError + 1001, _
Source:="TypeNotPresent", _
Description:="This function does not handle variable type: " & checkType & _
". Please create a case to handle it in the CheckPresent function."
End Select
' ------------------------------------------------------------------------------------
' Error handling for cases which do not have a CheckPresent datatype defined for them
' as of yet.
' ------------------------------------------------------------------------------------
TypeNotPresent_End:
Exit Function
TypeNotPresent_Err:
MsgBox Prompt:="Error number " & Err.Number & " was raised. " & _
vbCrLf & "Source: " & Err.Source & vbCrLf & _
"Description: " & Err.Description
Resume TypeNotPresent_End
End Function
在具有不同年末和四分位数的Excel数据透视表中分组
[英]grouping in an excel pivot table with different year end and quartiles
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.