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

deal with text box issues, div0 and escaping

Browse Source
This commit is contained in:
Trowbridge 2019-03-22 02:02:39 -04:00
parent 7d0ff997c1
commit 0be91dd6f8
5 changed files with 57 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
fpvt.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} fpvt
Caption = "Forecast Adjustment"
ClientHeight = 7260
ClientHeight = 7590
ClientLeft = 120
ClientTop = 465
ClientWidth = 7215
ClientWidth = 7095
OleObjectBlob = "fpvt.frx":0000
StartUpPosition = 1 'CenterOwner
End
@ -75,6 +75,8 @@ Private Sub butAdjust_Click()
Me.Hide
Set adjust = Nothing
End Sub
Private Sub butCancel_Click()
@ -256,6 +258,7 @@ Private Sub tbFcVal_Change()
End Sub
Private Sub tbFcVol_Change()
If load_tb Then Exit Sub
If opEditPrice Then calc_price
End Sub
@ -313,11 +316,16 @@ Private Sub UserForm_Activate()
fpvt.mod_adjust = False
pVol = 0
pVal = 0
pPrc = 0
bVol = 0
bVal = 0
bPrc = 0
aVol = 0
aVal = 0
aPrc = 0
fVal = 0
fVol = 0
fPrc = 0
For i = 1 To sp("package")("totals").Count
Select Case sp("package")("totals")(i)("order_season")
@ -350,6 +358,9 @@ Private Sub UserForm_Activate()
Else
pPrc = (pVal + bVal) / (bVol + pVol) - bVal / bVol
End If
If aVal <> 0 Then
MsgBox (aVal)
End If
Me.load_mbox_ann
'---------------------------------------populate monthly-------------------------------------------------------
@ -645,8 +656,9 @@ Sub calc_val()
End Sub
Sub calc_price()
If IsNumeric(tbFcPrice.value) And tbFcPrice.value <> 0 And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then
'If IsNumeric(tbFcPrice.value) And tbFcPrice.value <> 0 And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then
If IsNumeric(tbFcPrice.value) And IsNumeric(tbFcVol.value) And tbFcVol.value <> 0 Then
'capture currently changed item
fVol = tbFcVol.value
fPrc = tbFcPrice.value
@ -657,9 +669,14 @@ Sub calc_price()
If nomonth Then
aPrc = fVal / fVol - bPrc
Else
aPrc = fVal / fVol - ((bVal + pVal) / (bVol + pVol))
If (bVol + pVol) = 0 Then
aPrc = 0
Else
aPrc = fVal / fVol - ((bVal + pVal) / (bVol + pVol))
End If
End If
Else
fVol = co_num(tbFcVol.value, 0)
fVal = 0
aVal = fVal - bVal - pVal
End If

BIN
fpvt.frx
View File

Binary file not shown.

20
handler.bas
View File

@ -207,6 +207,11 @@ Function request_adjust(doc As String, ByRef fail As Boolean) As Object
Dim j As Integer
Dim str() As String
If doc = "" Then
fail = True
Exit Function
End If
Set json = JsonConverter.ParseJson(doc)
server = Sheets("config").Cells(1, 2)
@ -390,14 +395,18 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
If sh.Cells(i, 7) <> 0 Then
sh.Cells(i + 1, 7) = sh.Cells(i, 7)
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 7) = 0
Else
sh.Cells(i + 1, 7) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
sh.Cells(i + 1, 7) = pkg(i, 6) / pkg(i, 2)
End If
'--adjust--
If (pkg(i, 3) + pkg(i, 2)) = 0 Then
If (pkg(i, 3) + pkg(i, 2)) = 0 Or 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))
@ -414,7 +423,11 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
If sh.Cells(i, 10) <> 0 Then
sh.Cells(i + 1, 10) = sh.Cells(i, 10)
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
If pkg(13, 1) + pkg(13, 2) = 0 Then
sh.Cells(i + 1, 10) = 0
Else
sh.Cells(i + 1, 10) = (pkg(13, 5) + pkg(13, 6)) / (pkg(13, 1) + pkg(13, 2))
End If
End If
Else
sh.Cells(i + 1, 10) = pkg(i, 8) / pkg(i, 4)
@ -441,6 +454,7 @@ Sub month_tosheet(ByRef pkg() As Variant, ByRef basket() As Variant)
months.load_sheet
End Sub
Function co_num(ByRef one As Variant, ByRef two As Variant) As Variant

7
months.cls
View File

@ -325,6 +325,7 @@ Sub load_sheet()
Call Me.crunch_array
Call Me.set_sheet
Call Me.print_basket
Call Me.set_format
End Sub
@ -843,6 +844,10 @@ Sub new_part()
part.Show
If Not part.useval Then
Exit Sub
End If
dumping = True
Worksheets("month").Range("B33:Q10000").ClearContents
@ -863,7 +868,7 @@ Sub new_part()
i = i + 1
Loop
i = i - 1
If i = -1 Then i = 0
ReDim b(i, 3)
i = 0
Do Until Worksheets("month").Cells(33 + i, 2) = ""

19
pivot.cls
View File

@ -14,9 +14,9 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean
If Intersect(target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
@ -46,7 +46,6 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean
Set rd = target.Cells.PivotTable.RowFields
Set cd = target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = target.Cells.PivotCell.PivotTable
@ -56,19 +55,17 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean
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 & " = '" & ri(i).Name & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & ri(i).Name & """"
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape(ri(i).Name) & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape(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
nopiv:
End Sub
@ -100,6 +97,14 @@ Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
End Function
Function escape(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", """""")
escape = text
End Function