save work

This commit is contained in:
Trowbridge 2019-03-05 11:41:11 -05:00
parent 678c0cafc9
commit 85c3269bcc
4 changed files with 258 additions and 125 deletions

156
fpvt.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00 VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
Caption = "Forecast Adjustment" Caption = "Forecast Adjustment"
ClientHeight = 7275 ClientHeight = 7260
ClientLeft = 120 ClientLeft = 120
ClientTop = 465 ClientTop = 465
ClientWidth = 13695 ClientWidth = 16140
OleObjectBlob = "fpvt.frx":0000 OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner StartUpPosition = 1 'CenterOwner
End End
@ -14,11 +14,10 @@ Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False Attribute VB_Exposed = False
Public mod_adjust As Boolean Public mod_adjust As Boolean
Public month() As Variant Private month() As Variant
Private mload() As Variant
Option Explicit Option Explicit
Private Sub cbCancel_Click() Private Sub cbCancel_Click()
tbAdjVol.value = 0 tbAdjVol.value = 0
@ -45,6 +44,73 @@ Private Sub chbPlug_Change()
End Sub End Sub
Private Sub lbMonth_Change()
Dim i As Long
For i = 0 To 12
If lbMonth.Selected(i) Then
If i <> 0 Then
'------------base-------------------------------------
tbMBaseVal.value = co_num(month(i, 6), 0)
tbMBaseVol.value = co_num(month(i, 2), 0)
tbmPAVal.value = co_num(month(i, 7), 0)
tbMPAVol.value = co_num(month(i, 3), 0)
tbMFVal.value = co_num(month(i, 8), 0)
tbMFVol.value = co_num(month(i, 4), 0)
If tbMBaseVol <> 0 Then
tbMBasePrice = Format(tbMBaseVal / tbMBaseVol, "#.000")
Else
tbMBasePrice = 0
End If
If tbMFVol <> 0 Then
tbMFPrice = Format(tbMFVal / tbMFVol, "#.000")
Else
tbMFPrice = 0
End If
Else
tbMBaseVal.value = 0
tbMBaseVol.value = 0
tbmPAVal.value = 0
tbMPAVol.value = 0
tbMFVal.value = 0
tbMFVol.value = 0
tbMBasePrice = 0
tbMFPrice = 0
End If
Exit For
End If
Next i
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub opmprice_Click()
tbMFVal = Format(CDbl(tbmPAVal.value) + CDbl(tbMBaseVal.value) + CDbl(tbMAVal.value), "#,###")
tbMFVol = Format((CDbl(tbMPAVol.value) + CDbl(tbMBaseVol.value)), "#,###")
tbMFPrice = Format(CDbl(tbMFVal.value) / CDbl(tbMFVol.value), "#.000")
End Sub
Private Sub opmvol_Click()
Dim pchange As Double
'---------calculate percent change----------------------------------------------------------------------
pchange = 1 + CDbl(tbMAVal.value) / (CDbl(tbmPAVal.value) + CDbl(tbMBaseVal.value))
'---------add the adjustments together to get the new forecast------------------------------------------
tbMFVal = Format(CDbl(tbmPAVal.value) + CDbl(tbMBaseVal.value) + CDbl(tbMAVal.value), "#,###")
tbMFVol = Format((CDbl(tbMPAVol.value) + CDbl(tbMBaseVol.value)) * pchange, "#,###")
tbMFPrice = Format(CDbl(tbMFVal.value) / CDbl(tbMFVol.value), "#.000")
End Sub
Private Sub opprice_Click() Private Sub opprice_Click()
tbFcVal = Format(CDbl(tbPadjVal.value) + CDbl(tbBaseVal.value) + CDbl(tbAdjVal.value), "#,###") tbFcVal = Format(CDbl(tbPadjVal.value) + CDbl(tbBaseVal.value) + CDbl(tbAdjVal.value), "#,###")
@ -101,11 +167,40 @@ Private Sub tbAdjVol_Change()
End Sub End Sub
Private Sub tbMAVal_Change()
Dim pchange As Double
If IsNumeric(tbMAVal.value) Then
'---------calculate percent change----------------------------------------------------------------------
pchange = 1 + CDbl(tbMAVal.value) / (CDbl(tbMAVal.value) + CDbl(tbMBaseVal.value))
'---------add the adjustments together to get the new forecast------------------------------------------
tbMFVal = Format(CDbl(tbmPAVal.value) + CDbl(tbMBaseVal.value) + CDbl(tbMAVal.value), "#,###")
'---------if volume adjustment method is selected, scale the volume up----------------------------------
If opmvol Then
tbMFVol = Format((CDbl(tbMPAVol.value) + CDbl(tbMBaseVol.value)) * pchange, "#,###")
Else
tbMFVol = Format((CDbl(tbMPAVol.value) + CDbl(tbMBaseVol.value)), "#,###")
End If
tbMFPrice = Format(CDbl(tbMFVal.value) / CDbl(tbMFVol.value), "#.000")
Else
tbMFVal = Format(CDbl(tbmPAVal.value) + CDbl(tbMBaseVal.value), "#,###")
tbMFVol = Format((CDbl(tbMPAVol.value) + CDbl(tbMBaseVol.value)), "#,###")
tbMFPrice = Format(CDbl(tbMFVal.value) / CDbl(tbMFVol.value), "#.000")
End If
End Sub
Private Sub UserForm_Activate() Private Sub UserForm_Activate()
Dim sp As Object Dim sp As Object
Dim i As Long Dim i As Long
Dim j As Long
Dim k As Long
Dim ok As Boolean Dim ok As Boolean
handler.server = "http://10.56.1.20:3000"
'handler.server = "http://192.168.1.69:3000"
Set sp = handler.scenario_package(handler.scenario, ok) Set sp = handler.scenario_package(handler.scenario, ok)
@ -142,10 +237,59 @@ Private Sub UserForm_Activate()
'---------------------------------------populate monthly------------------------------------------------------- '---------------------------------------populate monthly-------------------------------------------------------
k = 0
'--parse json into variant array for loading-- '--parse json into variant array for loading--
ReDim month(sp("package")("mpvt").Count, 8)
For i = 1 To sp("package")("mpvt").Count
month(i, 0) = sp("package")("mpvt")(i)("order_month")
month(i, 1) = Format(sp("package")("mpvt")(i)("2019 qty"), "#,###")
month(i, 2) = Format(sp("package")("mpvt")(i)("2020 base qty"), "#,###")
month(i, 3) = Format(sp("package")("mpvt")(i)("2020 adj qty"), "#,###")
month(i, 4) = Format(sp("package")("mpvt")(i)("2020 tot qty"), "#,###")
month(i, 5) = Format(sp("package")("mpvt")(i)("2019 value_usd"), "#,###")
month(i, 6) = Format(sp("package")("mpvt")(i)("2020 base value_usd"), "#,###")
month(i, 7) = Format(sp("package")("mpvt")(i)("2020 adj value_usd"), "#,###")
month(i, 8) = Format(sp("package")("mpvt")(i)("2020 tot value_usd"), "#,###")
Next i
month(0, 0) = "month"
month(0, 1) = "2019 qty"
month(0, 2) = "2020 base qty"
month(0, 3) = "2020 adj qty"
month(0, 4) = "2020 qty"
month(0, 5) = "2019 val"
month(0, 6) = "2020 base val"
month(0, 7) = "2020 adj val"
month(0, 8) = "2020 val"
ReDim mload(UBound(month, 1), 5)
For i = 0 To UBound(month, 1)
mload(i, 0) = month(i, 0)
mload(i, 1) = month(i, 1)
mload(i, 2) = month(i, 4)
mload(i, 3) = month(i, 5)
mload(i, 4) = month(i, 8)
Next i
lbMonth.list = mload
lbMonth.ColumnCount = 8
'MsgBox (lbMonth.list(0, 0))
Application.StatusBar = False Application.StatusBar = False
End Sub End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant
If one = "" Or IsNull(one) Then
co_num = two
Else
co_num = one
End If
End Function

BIN
fpvt.frx

Binary file not shown.

View File

@ -9,11 +9,12 @@ Public wapi As New Windows_API
Public data() As String Public data() As String
Public agg() As String Public agg() As String
Public showprice As Boolean Public showprice As Boolean
Public server As String
Sub load_fpvt() Sub load_fpvt()
fpvt.sbEdit.SimpleText = "retrieving data.........." Application.StatusBar = "retrieving selection data....."
'data = x.SHTp_Get("data", 1, 1, True) 'data = x.SHTp_Get("data", 1, 1, True)
'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30)) 'Call x.TBLp_Aggregate(data, True, True, True, Array(1, 3), Array("S", "S"), Array(30))
@ -34,39 +35,21 @@ Sub load_fpvt()
If showprice Then If showprice Then
fpvt.opvolume.Visible = False fpvt.opvolume.Visible = False
fpvt.opprice.Visible = False fpvt.opprice.Visible = False
'fpvt.tbBasePrice.BackColor = &H80000005
'fpvt.tbBaseVol.BackColor = &H80000005
fpvt.tbAdjPrice.BackColor = &H80000005 fpvt.tbAdjPrice.BackColor = &H80000005
fpvt.tbAdjVol.BackColor = &H80000005 fpvt.tbAdjVol.BackColor = &H80000005
fpvt.tbAdjVal.BackColor = &H80000004 fpvt.tbAdjVal.BackColor = &H80000004
fpvt.tbAdjVal.Enabled = False fpvt.tbAdjVal.Enabled = False
'fpvt.tbFcPrice.BackColor = &H80000005
'fpvt.tbFcVol.BackColor = &H80000005
'enabled
'fpvt.tbBasePrice.Enabled = True
'fpvt.tbBaseVol.Enabled = True
fpvt.tbAdjPrice.Enabled = True fpvt.tbAdjPrice.Enabled = True
fpvt.tbAdjVol.Enabled = True fpvt.tbAdjVol.Enabled = True
'fpvt.tbFcPrice.Enabled = True
'fpvt.tbFcVol.Enabled = True
Else Else
fpvt.opvolume.Visible = True fpvt.opvolume.Visible = True
fpvt.opprice.Visible = True fpvt.opprice.Visible = True
'fpvt.tbBasePrice.BackColor = &H80000003
'fpvt.tbBaseVol.BackColor = &H80000003
fpvt.tbAdjPrice.BackColor = &H80000003 fpvt.tbAdjPrice.BackColor = &H80000003
fpvt.tbAdjVol.BackColor = &H80000003 fpvt.tbAdjVol.BackColor = &H80000003
fpvt.tbAdjVal.BackColor = &H80000005 fpvt.tbAdjVal.BackColor = &H80000005
fpvt.tbAdjVal.Enabled = True fpvt.tbAdjVal.Enabled = True
'fpvt.tbFcPrice.BackColor = &H80000003
'fpvt.tbFcVol.BackColor = &H80000003
'enabled
'fpvt.tbBasePrice.Enabled = False
'fpvt.tbBaseVol.Enabled = False
fpvt.tbAdjPrice.Enabled = False fpvt.tbAdjPrice.Enabled = False
fpvt.tbAdjVol.Enabled = False fpvt.tbAdjVol.Enabled = False
'fpvt.tbFcPrice.Enabled = False
'fpvt.tbFcVol.Enabled = False
End If End If
@ -78,70 +61,16 @@ Sub load_fpvt()
End Sub End Sub
Function request_adjust(doc As String) As Object
Sub pull_months(doc As String)
Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API
Dim wr As String
Dim json As Object
Dim i As Long
With req
'.Open "GET", "http://10.56.1.108:3000/monthly_orders", True
.Open "GET", "http://192.168.1.69:3000/monthly_orders", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Call wapi.ClipBoard_SetData(wr)
'MsgBox (wr)
On Error GoTo jerr
Set json = JsonConverter.ParseJson(wr)
jerr:
If Err.Number <> 0 Then
MsgBox ("function call error:" & vbCrLf & wr)
Exit Sub
End If
On Error GoTo errh
Sheets("test").range("A2:D1000").ClearContents
Sheets("test").range("N3:Q14").ClearContents
For i = 1 To json("jsonb_agg").Count
Sheets("test").Cells(i + 1, 1) = json("jsonb_agg")(i)("oseas")
Sheets("test").Cells(i + 1, 2) = json("jsonb_agg")(i)("monthn")
Sheets("test").Cells(i + 1, 3) = json("jsonb_agg")(i)("qty")
Sheets("test").Cells(i + 1, 4) = json("jsonb_agg")(i)("sales")
Next i
Sheets("test").Select
errh:
If Err.Number <> 0 Then
MsgBox (Err.Description)
End If
End Sub
Function scenario_totals(doc As String) As Object
Dim req As New WinHttp.WinHttpRequest Dim req As New WinHttp.WinHttpRequest
Dim json As Object Dim json As Object
Dim wr As String Dim wr As String
With req With req
'.Open "GET", "http://10.56.1.15:3000/get_pool", True '.Open "GET", "http://10.56.1.15:3000/scenario_totals", True
.Open "GET", "http://localhost:3000/scenario_totals", True '.Open "GET", "http://10.56.1.15:3000/scenario_totals", True
.Open "GET", "http://localhost:3000/request_adjust", True
.SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Content-Type", "application/json"
.Send doc .Send doc
.WaitForResponse .WaitForResponse
@ -153,7 +82,71 @@ Function scenario_totals(doc As String) As Object
End Function End Function
Sub pg_main_workset()
Function scenario_totals(doc As String, ByRef status As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
On Error GoTo errh
With req
'.Open "GET", "http://10.56.1.15:3000/scenario_totals", True
.Open "GET", "http://10.56.1.15:3000/scenario_totals", True
'.Open "GET", "http://localhost:3000/scenario_totals", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
Set scenario_totals = json
errh:
If Err.Number <> 0 Then
status = False
MsgBox (Err.Description)
Set scenario_totals = Nothing
Else
status = True
End If
End Function
Function scenario_package(doc As String, ByRef status As Boolean) As Object
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
On Error GoTo errh
With req
.Open "GET", server & "/scenario_package", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
Set scenario_package = json
errh:
If Err.Number <> 0 Then
status = False
MsgBox (Err.Description)
Set scenario_package = Nothing
Else
status = True
End If
End Function
Sub pg_main_workset(rep As String)
Dim req As New WinHttp.WinHttpRequest Dim req As New WinHttp.WinHttpRequest
Dim wapi As New Windows_API Dim wapi As New Windows_API
@ -165,11 +158,10 @@ Sub pg_main_workset()
Dim res() As Variant Dim res() As Variant
Dim str() As String Dim str() As String
doc = "{""quota_rep"":""90005 - MARK WILKINSON""}" doc = "{""quota_rep"":""" & rep & """}"
With req With req
'.Open "GET", "http://10.56.1.15:3000/get_pool", True .Open "GET", server & "/get_pool", True
.Open "GET", "http://192.168.1.69:3000/get_pool", True
.SetRequestHeader "Content-Type", "application/json" .SetRequestHeader "Content-Type", "application/json"
.Send doc .Send doc
.WaitForResponse .WaitForResponse
@ -179,7 +171,7 @@ Sub pg_main_workset()
Set json = JsonConverter.ParseJson(wr) Set json = JsonConverter.ParseJson(wr)
ReDim res(json("x").Count, 32) ReDim res(json("x").Count, 32)
For i = 1 To UBound(res, 1) - 1 For i = 1 To UBound(res, 1)
res(i, 0) = json("x")(i)("bill_cust_descr") res(i, 0) = json("x")(i)("bill_cust_descr")
res(i, 1) = json("x")(i)("billto_group") res(i, 1) = json("x")(i)("billto_group")
res(i, 2) = json("x")(i)("ship_cust_descr") res(i, 2) = json("x")(i)("ship_cust_descr")
@ -267,3 +259,33 @@ Sub pg_main_workset()
Call x.SHTp_Dump(str, "data", 1, 1, True, False, 28, 29, 30, 31, 32) Call x.SHTp_Dump(str, "data", 1, 1, True, False, 28, 29, 30, 31, 32)
End Sub End Sub
Sub pull_rep()
openf.Show
End Sub
Sub test()
Dim req As New WinHttp.WinHttpRequest
Dim json As Object
Dim wr As String
With req
'.Open "GET", "http://10.56.1.15:3000/scenario_totals", True
'.Open "GET", "http://10.56.1.15:3000/scenario_package", True
.Open "GET", "http://localhost:3000/scenario_package", True
.SetRequestHeader "Content-Type", "application/json"
.Send handler.scenario
.WaitForResponse
wr = .ResponseText
End With
Set json = JsonConverter.ParseJson(wr)
'Set scenario_totals = json
End Sub

View File

@ -1,8 +1,8 @@
Option Explicit Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, Cancel As Boolean) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.range("b11:v100000")) Is Nothing Then If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Exit Sub Exit Sub
End If End If
@ -11,7 +11,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, Cancel As Boolean
If Target.Cells.PivotTable Is Nothing Then If Target.Cells.PivotTable Is Nothing Then
Exit Sub Exit Sub
End If End If
Cancel = True Cancel = True
@ -31,9 +30,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, Cancel As Boolean
Dim pi As PivotItem Dim pi As PivotItem
Dim wapi As New Windows_API Dim wapi As New Windows_API
Set ri = Target.Cells.PivotCell.RowItems Set ri = Target.Cells.PivotCell.RowItems
Set ci = Target.Cells.PivotCell.ColumnItems Set ci = Target.Cells.PivotCell.ColumnItems
Set df = Target.Cells.PivotCell.DataField Set df = Target.Cells.PivotCell.DataField
@ -55,44 +51,13 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, Cancel As Boolean
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & ri(i).Name & """" jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & ri(i).Name & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name handler.sc(i - 1, 1) = ri(i).Name
'the following looks for filtered items, but this is redundant because a single one has been isolated
'For Each pi In pt.PivotFields(piv_fld_index(rd(i).Name, pt)).PivotItems
' If Not pi.Visible Then
' sql = sql & vbCrLf & "AND " & rd(i).Name & " <> '" & pi.Name & "'"
' End If
'Next pi
Next i Next i
'this block loops through items selected in colums, which will be ignored for now
'For i = 1 To ci.Count
' sql = sql & vbCrLf & "AND "
' sql = sql & cd(piv_pos(cd, ci(i).Parent.Position)).Name & " = '" & ci(i).Name & "'"
'Next i
'this loop iterates through every pivot field (even if not in the PT) and determines filtered items
'For Each pf In Target.Cells.PivotTable.PivotFields
' For Each pi In pf.PivotItems
' If Not pi.Visible Then
' sql = sql & vbCrLf & "AND " & pf.Name & " <> '" & pi.Name & "'"
' End If
' Next pi
'Next pf
scenario = "{" & handler.jsql & "}" scenario = "{" & handler.jsql & "}"
'Sheets("test").Cells(1, 14) = handler.jsql
Call handler.load_fpvt Call handler.load_fpvt
'Call http.pull_months(scenario)
'jsql = "SELECT count(*) FROM rlarp.osm_ppfa_varto_jmv WHERE j @> '{" & jsql & "}'::jsonb"
'sql = "SELECT count(*) FROM rlarp.osm_ppfa_varto_jmv WHERE " & sql
'MsgBox (sql)
'Call wapi.ClipBoard_SetData(sql)
nopiv: nopiv:
End Sub End Sub
@ -126,3 +91,5 @@ End Function