forecast_api/VBA/shWalk.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "shWalk"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim pt As PivotTable
    Set pt = ActiveSheet.PivotTables("ptWalk")
    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

    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
    
    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
    
    ReDim handler.sc(ri.Count, 1)
    
    handler.sql = ""
    handler.jsql = ""

    For i = 1 To ri.Count
        If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
        If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
        handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
        jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
        handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
        handler.sc(i - 1, 1) = ri(i).Name
    Next i
    
    scenario = "{" & handler.jsql & "}"
    
    Call handler.load_config
    Call handler.load_fpvt

End Sub

Function piv_pos(list As Object, target_pos As Long) As Long

    Dim i As Long
    
    For i = 1 To list.Count
        If list(i).Position = target_pos Then
            piv_pos = i
            Exit Function
        End If
    Next i
    'should not get to this point

End Function

Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer

    Dim i As Integer
    
    For i = 1 To pt.PivotFields.Count
        If pt.PivotFields(i).Name = field_name Then
            piv_fld_index = i
            Exit Function
        End If
    Next i

End Function

Function escape_json(ByVal text As String) As String

    text = Replace(text, "'", "''")
    text = Replace(text, """", "\""")
    If text = "(blank)" Then text = ""
    escape_json = text

End Function

Function escape_sql(ByVal text As String) As String

    text = Replace(text, "'", "''")
    text = Replace(text, """", """""")
    If text = "(blank)" Then text = ""
    escape_sql = text

End Function