Use streamlined code to get pivot table key fields.

This allows me to get rid of unnecessary (and duplicated) code.
This commit is contained in:
PhilRunninger 2024-04-01 17:54:09 -04:00
parent 5b1333b8c1
commit 44dd489377
11 changed files with 44 additions and 111 deletions

Binary file not shown.

View File

@ -642,33 +642,6 @@ Public Function RangeToArray(inputRange As Range) As Variant()
End Function
Public 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
Public 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
Public Function escape_json(ByVal text As String) As String
text = Replace(text, "'", "''")

View File

@ -48,16 +48,16 @@ End Sub
Private Sub butAdjust_Click()
Dim errorMsg As String
If tbapi.text = "" Then errorMsg = "No adjustments provided."
If tbAPI.text = "" Then errorMsg = "No adjustments provided."
If cbTAG.text = "" Then errorMsg = "No tag was selected."
If tbapi.text = "" Then errorMsg = "No adjustements are ready."
If tbAPI.text = "" Then errorMsg = "No adjustements are ready."
If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbExclamation
Exit Sub
End If
handler.request_adjust tbapi.text, errorMsg
handler.request_adjust tbAPI.text, errorMsg
If errorMsg <> "" Then
MsgBox errorMsg, vbOKOnly Or vbExclamation, "Adjustment was not made due to error."
Exit Sub
@ -93,10 +93,10 @@ End Sub
Private Sub cbTAG_Change()
Dim j As Object
If tbapi.text = "" Then tbapi.text = "{}"
Set j = JsonConverter.ParseJson(tbapi.text)
If tbAPI.text = "" Then tbAPI.text = "{}"
Set j = JsonConverter.ParseJson(tbAPI.text)
j("tag") = cbTAG.value
tbapi.text = JsonConverter.ConvertToJson(j)
tbAPI.text = JsonConverter.ConvertToJson(j)
End Sub
Private Sub opEditPrice_Click()
@ -160,10 +160,10 @@ Private Sub sbpv_Change()
End Sub
Private Sub tbCOM_Change()
If tbapi.text = "" Then tbapi.text = "{}"
Set adjust = JsonConverter.ParseJson(tbapi.text)
If tbAPI.text = "" Then tbAPI.text = "{}"
Set adjust = JsonConverter.ParseJson(tbAPI.text)
adjust("message") = tbCOM.text
tbapi.text = JsonConverter.ConvertToJson(adjust)
tbAPI.text = JsonConverter.ConvertToJson(adjust)
End Sub
Private Sub tbFcPrice_Change()
@ -232,7 +232,7 @@ Private Sub UserForm_Activate()
fVal = 0
fVol = 0
fPrc = 0
Me.tbapi.value = ""
Me.tbAPI.value = ""
If IsNull(sp("package")("totals")) Then
MsgBox "An unexpected error has occurred when retrieving the scenario.", vbOKOnly Or vbExclamation, "Error"
@ -486,7 +486,7 @@ Sub calc_val()
End If
'print json
tbapi = JsonConverter.ConvertToJson(adjust)
tbAPI = JsonConverter.ConvertToJson(adjust)
End Sub
Sub calc_price()
@ -537,7 +537,7 @@ Sub calc_price()
End If
'print json
tbapi = JsonConverter.ConvertToJson(adjust)
tbAPI = JsonConverter.ConvertToJson(adjust)
End Sub
Function iter_def(ByVal iter As String) As String

View File

@ -69,28 +69,32 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
Set rd = Target.Cells.PivotTable.RowFields
Set cd = Target.Cells.PivotTable.ColumnFields
Dim segmOffset As Integer
segmOffset = IIf(Right(segmSql, 2) = "()", 0, 1)
Dim idx As Integer
idx = IIf(Right(segmSql, 2) = "()", 0, 1)
handler.sql = ""
handler.jsql = ""
ReDim handler.sc(ri.Count + segmOffset, 1)
If segmOffset = 1 Then
handler.sql = segmSql
handler.jsql = segmJSql
handler.sql = IIf(idx = 0, "", segmSql)
handler.jsql = IIf(idx = 0, "", segmJSql)
ReDim handler.sc(ri.Count + idx - 1, 1)
If idx = 1 Then
handler.sc(0, 0) = "segm"
handler.sc(0, 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 & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
handler.jsql = handler.jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
handler.sc(i - 1 + segmOffset, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1 + segmOffset, 1) = ri(i).Name
handler.sql = handler.sql & key & " = '" & escape_sql(value) & "'"
handler.jsql = handler.jsql & """" & key & """:""" & escape_json(value) & """"
handler.sc(idx, 0) = key
handler.sc(idx, 1) = value
idx = idx + 1
Next i
scenario = "{" & handler.jsql & "}"

View File

@ -82,12 +82,11 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
handler.sql = IIf(idx = 0, "", segmSql)
handler.jsql = IIf(idx = 0, "", segmJSql)
ReDim handler.sc(ri.Count + ci.Count + idx, 1)
ReDim handler.sc(ri.Count + ci.Count + idx - 1, 1)
If idx = 1 Then
idx = 0
handler.sc(idx, 0) = "segm"
handler.sc(idx, 1) = Mid(segmJSql, 9)
handler.sc(0, 0) = "segm"
handler.sc(0, 1) = Mid(segmJSql, 9)
End If
Dim key As String
@ -101,9 +100,9 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
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
idx = idx + 1
Next i
For i = 1 To ci.Count
@ -114,9 +113,9 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean
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
idx = idx + 1
If key = "ship_season" Then selectedSeason = CInt(value)
If key = "ship_month" Then selectedMonth = CInt(Left(value, 2))

View File

@ -44,18 +44,23 @@ Attribute VB_Exposed = True
' Set rd = Target.Cells.PivotTable.RowFields
' Set cd = Target.Cells.PivotTable.ColumnFields
'
' ReDim handler.sc(ri.Count, 1)
' dim idx as Integer
'
' handler.sql = ""
' handler.jsql = ""
' ReDim handler.sc(ri.Count - 1, 1)
'
' For i = 1 To ri.Count
' key = ri(i).Parent.Name
' value = ri(i).value
' 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
' handler.sql = handler.sql & key & " = '" & escape_sql(value) & "'"
' jsql = jsql & """" & key & """:""" & escape_json(value) & """"
' handler.sc(idx, 0) = key
' handler.sc(idx, 1) = value
' idx = idx + 1
' Next i
'
' scenario = "{" & handler.jsql & "}"
@ -64,51 +69,3 @@ Attribute VB_Exposed = True
' 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
'
'