VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "shShipments" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit Dim selectedSeason As Integer Dim selectedMonth As Integer Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim pt As PivotTable Set pt = ActiveSheet.PivotTables("ptShipments") Dim intersec As Range Set intersec = Intersect(Target, pt.DataBodyRange) If intersec Is Nothing Then Exit Sub ElseIf intersec.address <> Target.address Then Exit Sub End If Cancel = True If Target.value = "" Then MsgBox "You cannot shift an empty cell.", vbOKOnly + vbExclamation Exit Sub End If Dim i As Long Dim j As Long Dim k As Long Dim ri As PivotItemList Dim ci As PivotItemList Dim df As Object Dim rd As Object Dim cd As Object Dim dd As Object Dim pf As PivotField Dim pi As PivotItem ' Serialize the report filters in SQL and JSON format. pt.PivotCache.MissingItemsLimit = xlMissingItemsNone pt.PivotCache.Refresh Dim segmSql As String Dim segmJSql As String segmSql = "segm IN (" segmJSql = """segm"": [" Set pf = pt.PivotFields("Segment") For Each pi In pf.PivotItems If pi.Visible Then If Right(segmSql, 1) <> "(" Then segmSql = segmSql & ", " segmJSql = segmJSql & ", " End If segmSql = segmSql & "'" & escape_sql(pi.Name) & "'" segmJSql = segmJSql & """" & escape_json(pi.Name) & """" End If Next segmSql = segmSql & ")" segmJSql = segmJSql & "]" ' Serialize the row and column items in SQL and JSON format. Set ri = Target.Cells.PivotCell.RowItems Set ci = Target.Cells.PivotCell.ColumnItems Set df = Target.Cells.PivotCell.DataField Set rd = Target.Cells.PivotTable.RowFields Set cd = Target.Cells.PivotTable.ColumnFields Dim idx As Integer idx = IIf(Right(segmSql, 2) = "()", 0, 1) handler.sql = IIf(idx = 0, "", segmSql) handler.jsql = IIf(idx = 0, "", segmJSql) ReDim handler.sc(ri.Count + ci.Count + idx, 1) If idx = 1 Then idx = 0 handler.sc(idx, 0) = "segm" handler.sc(idx, 1) = Mid(segmJSql, 9) End If Dim key As String Dim value As Variant For i = 1 To ri.Count key = ri(i).Parent.Name value = ri(i).value If handler.sql <> "" Then handler.sql = handler.sql & vbCrLf & "AND " If handler.sql <> "" Then handler.jsql = handler.jsql & vbCrLf & "," handler.sql = handler.sql & key & " = '" & escape_sql(value) & "'" handler.jsql = handler.jsql & """" & key & """:""" & escape_json(value) & """" idx = idx + 1 handler.sc(idx, 0) = key handler.sc(idx, 1) = value Next i For i = 1 To ci.Count key = ci(i).Parent.Name value = ci(i).value If handler.sql <> "" Then handler.sql = handler.sql & vbCrLf & "AND " If handler.sql <> "" Then handler.jsql = handler.jsql & vbCrLf & "," handler.sql = handler.sql & key & " = '" & escape_sql(value) & "'" handler.jsql = handler.jsql & """" & key & """:""" & escape_json(value) & """" idx = idx + 1 handler.sc(idx, 0) = key handler.sc(idx, 1) = value If key = "ship_season" Then selectedSeason = CInt(value) If key = "ship_month" Then selectedMonth = CInt(Left(value, 2)) Next scenario = "{" & handler.jsql & "}" If selectedSeason = 0 Or selectedMonth = 0 Then MsgBox "Invalid pivot table setup. Make sure SHIP_SEASON and SHIP_MONTH are set as pivot table columns.", vbOKOnly + vbExclamation Exit Sub End If Call handler.load_config With shipDateShifter .lbSDET.list = handler.sc .selectedSeason = selectedSeason .selectedMonth = selectedMonth .currentValue = Target.value .numberFormat = IIf(df.numberFormat Like "*$*", "$#,##0", "#,##0") .Show End With End Sub