pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

number of updates for monthly

Browse Source
This commit is contained in:
Trowbridge 2019-03-20 01:43:18 -04:00
parent dc6df26eba
commit f9d5aaf782
4 changed files with 120 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
fpvt.frm
View File

@ -4,7 +4,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
ClientHeight = 7260
ClientLeft = 120
ClientTop = 465
ClientWidth = 16140
ClientWidth = 17475
OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner
End
@ -101,6 +101,7 @@ End Sub
Private Sub cbGoSheet_Click()
Me.Hide
Worksheets("month").Visible = xlSheetVisible
Sheets("month").Select
End Sub
@ -328,8 +329,16 @@ Private Sub UserForm_Activate()
fVol = bVol + pVol
fVal = bVal + pVal
If fVol = 0 Then
fPrc = 0
Else
fPrc = fVal / fVol
End If
If (bVol + pVol) = 0 Then
pPrc = 0
Else
pPrc = (pVal + bVal) / (bVol + pVol) - bVal / bVol
End If
Me.load_mbox_ann
'---------------------------------------populate monthly-------------------------------------------------------

BIN
fpvt.frx
View File

Binary file not shown.

8
handler.bas
View File

@ -89,6 +89,7 @@ Sub pg_main_workset(rep As String)
doc = "{""quota_rep"":""" & rep & """}"
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
.Open "GET", handler.server & "/get_pool", True
.SetRequestHeader "Content-Type", "application/json"
.Send doc
@ -207,6 +208,7 @@ Function request_adjust(doc As String) As Object
Dim str() As String
Set json = JsonConverter.ParseJson(doc)
server = Sheets("config").Cells(1, 2)
With req
.Option(WinHttpRequestOption_SslErrorIgnoreFlags) = SslErrorFlag_Ignore_All
@ -389,7 +391,11 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
If co_num(pkg(i, 3), 0) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = pkg(i, 7) / pkg(i, 3) - pkg(i, 6) / pkg(i, 2)
If (pkg(i, 3) + pkg(i, 2)) = 0 Then
sh.Cells(i + 1, 8) = 0
Else
sh.Cells(i + 1, 8) = (pkg(i, 7) + pkg(i, 6)) / (pkg(i, 3) + pkg(i, 2)) - (pkg(i, 6) / pkg(i, 2))
End If
End If
'--current adjust--

107
months.cls
View File

@ -29,12 +29,12 @@ Private showbasket As Boolean
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Long
Dim b() As Variant
cancel = True
Cancel = True
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing Then
build.part = Sheets("month").Cells(Target.row, 2)
build.bill = rev_cust(Sheets("month").Cells(Target.row, 6))
@ -56,10 +56,10 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean
Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value
Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value)
Sheets("month").Cells(Target.row + i, 12) = rev_cust(build.cbShip.value)
'Sheets("month").Cells.Rows(Target.row + i).Select
dumping = False
Set basket_touch = Selection
Call Me.get_edit_basket
Target.Select
End If
@ -77,6 +77,44 @@ Public Function rev_cust(cust As String) As String
End Function
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Long
Dim b() As Variant
Cancel = True
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing Then
build.part = Sheets("month").Cells(Target.row, 2)
build.bill = rev_cust(Sheets("month").Cells(Target.row, 6))
build.ship = rev_cust(Sheets("month").Cells(Target.row, 12))
build.useval = False
build.Show
If build.useval Then
dumping = True
'if an empty row is selected, force it to be the next open slot
If Sheets("month").Cells(Target.row, 2) = "" Then
Do Until Sheets("month").Cells(Target.row + i, 2) <> ""
i = i - 1
Loop
i = i + 1
End If
Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value
Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value)
Sheets("month").Cells(Target.row + i, 12) = rev_cust(build.cbShip.value)
dumping = False
Set basket_touch = Selection
Call Me.get_edit_basket
Target.Select
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
@ -100,6 +138,8 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set
If Not Intersect(Target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj
If Not Intersect(Target, Range("R6:R17")) Is Nothing Then Call Me.ms_set
If Not Intersect(Target, Range("B33:Q1000")) Is Nothing Then
Set basket_touch = Target
Call Me.get_edit_basket
@ -166,6 +206,8 @@ End Sub
Sub ms_set()
On Error GoTo errh
Dim i As Integer
Call Me.get_sheet
Dim vp As String
@ -173,7 +215,7 @@ Sub ms_set()
For i = 1 To 12
If sales(i, 5) = "" Then sales(i, 5) = 0
If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 6) <> Round(sales(i, 4), 6) Then
If Round(sales(i, 5) - (sales(i, 2) + sales(i, 3)), 2) <> Round(sales(i, 4), 2) Then
sales(i, 4) = sales(i, 5) - (sales(i, 2) + sales(i, 3))
Select Case vp
Case "volume"
@ -214,6 +256,9 @@ Sub ms_set()
Me.crunch_array
Me.set_sheet
errh:
If Err.Number <> 0 Then rollback = True
End Sub
@ -282,7 +327,7 @@ Sub get_sheet()
tprice = Range("H18:L18")
tsales = Range("N18:R18")
ReDim adjust(12)
Set basejson = JsonConverter.ParseJson("{""scenario"":" & Sheets("_month").Range("P1").FormulaR1C1 & "}")
Set basejson = JsonConverter.ParseJson(Sheets("_month").Range("P1").FormulaR1C1)
End Sub
@ -455,6 +500,19 @@ End Sub
Sub build_json(ByVal pos As Integer)
Dim i As Long
Dim j As Long
ReDim handler.basis(100)
i = 2
j = 0
Do While Sheets("config").Cells(2, i) <> ""
handler.basis(j) = Sheets("config").Cells(2, i)
j = j + 1
i = i + 1
Loop
ReDim Preserve handler.basis(j - 1)
'if something is changing
If Round(units(pos, 4), 2) <> 0 Or (Round(price(pos, 4), 8) <> 0 And Round(units(pos, 5), 2) <> 0) Then
Set adjust(pos) = JsonConverter.ParseJson(JsonConverter.ConvertToJson(basejson))
@ -468,13 +526,17 @@ Sub build_json(ByVal pos As Integer)
'if the target price is the same as average and a month is being added
adjust(pos)("type") = "addmonth_v"
End If
adjust(pos)("month") = Worksheets("month").Cells(5 + pos, 1)
adjust(pos)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4)
Else
'scale the existing volume(price) on the target month
If Round(price(pos, 4), 8) <> 0 Then
'if the target price is diferent from the average and a month is being added
If Round(units(pos, 4), 2) <> 0 Then
adjust(pos)("type") = "scale_vp"
Else
adjust(pos)("type") = "scale_p"
End If
Else
'if the target price is the same as average and a month is being added
adjust(pos)("type") = "scale_v"
@ -482,6 +544,11 @@ Sub build_json(ByVal pos As Integer)
adjust(pos)("qty") = units(pos, 4)
adjust(pos)("amount") = sales(pos, 4)
End If
adjust(pos)("stamp") = Format(DateTime.Now, "yyyy-MM-dd hh:mm:ss")
adjust(pos)("user") = Application.UserName
adjust(pos)("scenario")("version") = "b20"
adjust(pos)("scenario")("iter") = handler.basis
adjust(pos)("source") = "adj"
End If
End Sub
@ -515,14 +582,18 @@ Sub crunch_array()
tprice(1, 5) = 0
End If
'adjust
If (tunits(1, 2) + tunits(1, 3)) = 0 Then
tprice(1, 3) = 0
Else
tprice(1, 3) = (tsales(1, 2) + tsales(1, 3)) / (tunits(1, 2) + tunits(1, 3)) - tprice(1, 2)
End If
'current adjust
tprice(1, 4) = tprice(1, 5) - (tprice(1, 2) + tprice(1, 3))
End Sub
Sub cancel()
Sub Cancel()
Sheets("Orders").Select
@ -531,7 +602,11 @@ End Sub
Sub reset()
Call Me.load_sheet
If showbasket Then
showbasket = False
Else
showbasket = True
End If
End Sub
@ -654,9 +729,25 @@ Sub get_edit_basket()
Worksheets("_month").Range("U2:X5000").ClearContents
Call x.SHTp_DumpVar(b, "_month", 2, 21, False, False, True)
'orig.Select
End Sub
Sub post_adjust()
Dim i As Long
For i = 2 To 13
If Sheets("_month").Cells(i, 16) <> "" Then
Call handler.request_adjust(Sheets("_month").Cells(i, 16))
End If
Next i
Sheets("Orders").Select
Worksheets("month").Visible = xlHidden
End Sub