pt/forecast_api
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
dev
forecast_api/VBA/Utils.bas
PhilRunninger fde6c97964 Too many changes, too few commits. 
A lot has changed here, including:
1. Adding pounds to the data available for display in pivot table.
2. Visual improvements
3. Code simplification
4. Hiding / showing sheets as needed. A developer's backdoor allows for
   easy toggling for debugging purposes: Ctrl+RightClick on the Forecast
   Adjustment form's "Selected Scenario" label.
5. Fixed a bug that happened when deleting rows from the basket. The
   definition of the Target variable was lost in some cases.
6. Made use of the Cancel and Default form properties to purge some
   unnecessary code.
7. Added a sheet that contains Help text for the users.
8. Replacing more harcoded range reference with range names.
9. Refactor checks for division by zero errors, and improve error
   messages for users.
10. Remove manual formatting. It's already done and saved in the
    workbook; there's no need to redo it in code.
11. Added more data validation before Save operation proceeds.
12. Added a new IntersectsWith function to simplify If statements.
2023-04-24 21:46:13 -04:00

621 lines
16 KiB
QBasic
Raw Permalink Blame History

Attribute VB_Name = "Utils"
Option Explicit
Public ADOo_errstring As String
Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, ByRef headers As Boolean, ByRef del_unused As Boolean, ParamArray groupnum_type_sumnum()) As Boolean
Dim i As Long
Dim j As Long
Dim nt() As String
Dim keep() As Integer
If needsort Then
If Not TBLp_BubbleSortAsc(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetStringArray(1, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
End If
If Not TBLp_Roll(tbl, PAp_2DGetIntegerArray(0, groupnum_type_sumnum), PAp_2DGetIntegerArray(2, groupnum_type_sumnum), headers) Then
TBLp_Aggregate = False
Exit Function
End If
If del_unused Then
keep = PAp_2DGetMultIntegerArray(ARRAYp_MakeInteger(0, 2), groupnum_type_sumnum)
ReDim nt(UBound(keep()), UBound(tbl, 2))
For i = 0 To UBound(keep())
For j = 0 To UBound(tbl, 2)
nt(i, j) = tbl(keep(i), j)
Next j
Next i
tbl = nt
End If
TBLp_Aggregate = True
End Function
Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean
On Error GoTo errh
'get fort field numbers
'loop through each row and generate the row key
'eveluate the row key against other row keys
'perform swaps
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
If headers Then k = 1
For i = k To UBound(tbl, 2) - 1
For j = i + 1 To UBound(tbl, 2)
If ROWe_AscSwapFlag(tbl, i, j, sortflds, typeflds) Then
Call ROWp_Swap(tbl, i, j)
Else
If ADOo_errstring <> "" Then
TBLp_BubbleSortAsc = False
Exit Function
End If
End If
Next j
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at TBLP_BubbleSortAsc." & vbCrLf & Err.Description)
ADOo_errstring = Err.Description
End If
TBLp_BubbleSortAsc = True
End Function
Public Function TBLp_Roll(ByRef tbl() As String, ByRef gflds() As Integer, ByRef sflds() As Integer, ByRef headers As Boolean) As Boolean
On Error GoTo errh
Dim i As Long 'indexes primary row
Dim j As Long 'indexes secondary chaecker row
Dim k As Integer 'used to start at 0 or 1
Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1
k = 0
If headers Then k = 1
m = k
For i = k To UBound(tbl, 2)
If i = UBound(tbl, 2) Then
i = i
End If
j = i + 1
Do
If j > UBound(tbl, 2) Then Exit Do
If ROWe_MatchesFlag(tbl, i, j, gflds) Then
Call ROWp_Aggregate2Rows(tbl, i, j, sflds)
Else
Exit Do
End If
j = j + 1
If j > UBound(tbl, 2) Then
Exit Do
End If
Loop
Call ROWp_Copy(tbl, i, m)
m = m + 1
i = j - 1
Next i
ReDim Preserve tbl(UBound(tbl, 1), m - 1)
errh:
If Err.Number <> 0 Then
ADOo_errstring = Err.Description
TBLp_Roll = False
Exit Function
End If
TBLp_Roll = True
End Function
Sub ROWp_Swap(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long)
Dim temprow() As String
ReDim temprow(UBound(tbl, 1))
Dim i As Integer
For i = 0 To UBound(tbl, 1)
temprow(i) = tbl(i, p2)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p2) = tbl(i, p1)
Next i
For i = 0 To UBound(tbl, 1)
tbl(i, p1) = temprow(i)
Next i
End Sub
Sub ROWp_Copy(ByRef tbl() As String, ByRef r_from As Long, ByRef r_to As Long)
Dim i As Integer
For i = 0 To UBound(tbl, 1)
tbl(i, r_to) = tbl(i, r_from)
Next i
End Sub
Sub ROWp_Aggregate2Rows(ByRef tbl() As String, ByRef p1 As Long, ByRef p2 As Long, ByRef sflds() As Integer)
Dim i As Integer
On Error GoTo exitsub
For i = 0 To UBound(sflds, 1)
tbl(sflds(i), p1) = CDbl(tbl(sflds(i), p1)) + CDbl(tbl(sflds(i), p2))
Next i
exitsub:
End Sub
Function ROWe_AscSwapFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer, ByRef TypeFld() As String) As Boolean
'only returns true if greater than
On Error GoTo errh
Dim i As Integer
Dim compare As Integer
For i = 0 To UBound(KeyFld)
Select Case TypeFld(i)
Case "S"
compare = MISCe_CompareString(CStr(tbl(KeyFld(i), row1)), CStr(tbl(KeyFld(i), row2)))
Case "N"
compare = MISCe_CompareDouble(CDbl(tbl(KeyFld(i), row1)), CDbl(tbl(KeyFld(i), row2)))
Case "D"
compare = MISCe_CompareDate(CDate(tbl(KeyFld(i), row1)), CDate(tbl(KeyFld(i), row2)))
End Select
Select Case compare
Case -1
ROWe_AscSwapFlag = True
Exit Function
Case 1
ROWe_AscSwapFlag = False
Exit Function
End Select
Next i
errh:
If Err.Number <> 0 Then
MsgBox ("Error at ROWe_AscSwapFlag." & vbCrLf & Err.Description)
ADOo_errstring = Err.Description
Exit Function
End If
End Function
Function ROWe_MatchesFlag(ByRef tbl() As String, ByRef row1 As Long, ByRef row2 As Long, ByRef KeyFld() As Integer) As Boolean
'only returns true if greater than
Dim i As Integer
Dim k1 As String
Dim k2 As String
For i = 0 To UBound(KeyFld())
k1 = k1 & tbl(KeyFld(i), row1)
Next i
For i = 0 To UBound(KeyFld())
k2 = k2 & tbl(KeyFld(i), row2)
Next i
If k2 = k1 Then
ROWe_MatchesFlag = True
Else
ROWe_MatchesFlag = False
End If
End Function
Sub SHTp_DumpVar(ByRef tbl() As Variant, ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef clear As Boolean, ByRef transpose As Boolean, ByRef zerobase As Boolean)
Dim sh As Worksheet
Dim address As String
Set sh = Sheets(sheet)
'If clear Then sh.Cells.clear
'If transpose Then Call ARRAYp_Transpose(tbl)
If zerobase Then
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1), col + UBound(tbl, 2)).address
Else
address = sh.Cells(row, col).address & ":" & sh.Cells(row + UBound(tbl, 1) - 1, col + UBound(tbl, 2) - 1).address
End If
sh.Range(address).FormulaR1C1 = tbl
On Error GoTo errhndl
errhndl:
If Err.Number <> 0 Then MsgBox ("Error in dumping to sheet" & vbCrLf & Err.Description)
End Sub
Function ARRAYp_TransposeVar(ByRef a() As Variant) As Variant()
Dim s() As Variant
ReDim s(UBound(a, 2), UBound(a, 1))
Dim i As Long
Dim j As Long
For i = 0 To UBound(s, 1)
For j = 0 To UBound(s, 2)
s(i, j) = a(j, i)
Next j
Next i
ARRAYp_TransposeVar = s
End Function
Function ARRAYp_zerobased_addheader(ByRef z() As Variant, ParamArray cols()) As Variant()
Dim i As Long
Dim j As Long
Dim r() As Variant
ReDim r(UBound(z, 1), UBound(z, 2) + 1)
For i = 0 To UBound(r, 1)
For j = 1 To UBound(r, 2)
r(i, j) = z(i, j - 1)
Next j
r(i, 0) = cols(i)
Next i
ARRAYp_zerobased_addheader = r
End Function
Public Function SHTp_Get(ByRef sheet As String, ByRef row As Long, ByRef col As Long, ByRef headers As Boolean) As String()
Dim i As Long
Dim j As Long
Dim table() As String
Dim sh As Worksheet
Set sh = Sheets(sheet)
On Error GoTo errhdnl
i = 1
While sh.Cells(row, col + i - 1) <> ""
i = i + 1
Wend
j = 1
While sh.Cells(row + j - 1, col) <> ""
j = j + 1
Wend
ReDim table(i - 2, j - 2)
i = 1
While i <= UBound(table, 1) + 1
j = 0
While j <= UBound(table, 2)
table(i - 1, j) = sh.Cells(row + j, col + i - 1)
j = j + 1
Wend
i = i + 1
Wend
errhdnl:
If Err.Number <> 0 Then
MsgBox (Err.Description)
End If
SHTp_Get = table
End Function
Function PAp_2DGetStringArray(ByRef index As Integer, ParamArray pa()) As String()
Dim str() As String
Dim i As Long
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
PAp_2DGetStringArray = str
End Function
Function PAp_2DGetIntegerArray(ByRef index As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
If UBound(pa(0)(index)) <> -1 Then
ReDim str(UBound(pa(0)(index)))
For i = 0 To UBound(pa(0)(index))
str(i) = pa(0)(index)(i)
Next i
End If
PAp_2DGetIntegerArray = str
End Function
Function PAp_2DGetMultIntegerArray(ByRef ArraysGet() As Integer, ParamArray pa()) As Integer()
Dim str() As Integer
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim index As Long
'get length of selected arrays
For i = 0 To UBound(ArraysGet, 1)
cnt = cnt + UBound(pa(0)(ArraysGet(i)))
Next i
ReDim str(cnt + 1)
cnt = 0
For i = 0 To UBound(ArraysGet, 1)
For j = 0 To UBound(pa(0)(ArraysGet(i)))
str(cnt) = pa(0)(ArraysGet(i))(j)
cnt = cnt + 1
Next j
Next i
PAp_2DGetMultIntegerArray = str
End Function
Public Function ARRAYp_MakeInteger(ParamArray items()) As Integer()
Dim X() As Integer
Dim i As Integer
ReDim X(UBound(items))
For i = 0 To UBound(items())
X(i) = items(i)
Next i
ARRAYp_MakeInteger = X
End Function
Public Function MISCe_CompareString(ByRef base As String, ByRef compare As String) As Integer
If compare < base Then
MISCe_CompareString = -1
Exit Function
End If
If compare = base Then
MISCe_CompareString = 0
Exit Function
End If
If compare > base Then
MISCe_CompareString = 1
Exit Function
End If
End Function
Public Function MISCe_CompareDouble(ByRef base As Double, ByRef compare As Double) As Integer
If compare < base Then
MISCe_CompareDouble = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDouble = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDouble = 1
Exit Function
End If
End Function
Public Function MISCe_CompareDate(ByRef base As Date, ByRef compare As Date) As Integer
If compare < base Then
MISCe_CompareDate = -1
Exit Function
End If
If compare = base Then
MISCe_CompareDate = 0
Exit Function
End If
If compare > base Then
MISCe_CompareDate = 1
Exit Function
End If
End Function
Public Function json_from_table(ByRef tbl() As Variant, ByRef array_label As String, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 2 To UBound(tbl, 1)
For c = 1 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(1, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 2 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
If r > 3 Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table = ajson
End Function
Public Function json_from_table_zb(ByRef tbl() As Variant, ByRef array_label As String, ByVal force_array As Boolean, Optional strip_braces As Boolean) As String
Dim ajson As String
Dim json As String
Dim r As Integer
Dim c As Integer
Dim needs_comma As Boolean
Dim needs_braces As Integer
needs_comma = False
needs_braces = 0
ajson = ""
For r = 1 To UBound(tbl, 1)
For c = 0 To UBound(tbl, 2)
If tbl(r, c) <> "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric(tbl(r, c)) And Mid(tbl(r, c), 1, 1) <> 0 Then
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & tbl(r, c)
Else
'test if item is a json object
If Mid(tbl(r, c), 1, 1) = "{" Or Mid(tbl(r, c), 1, 1) = "[" Then
json = json & """" & tbl(0, c) & """" & ":" & tbl(r, c)
Else
json = json & Chr(34) & tbl(0, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34)
End If
End If
End If
Next c
If needs_braces > 0 Then json = "{" & json & "}"
needs_comma = False
needs_braces = 0
If r > 1 Then
ajson = ajson & "," & json
Else
ajson = json
End If
json = ""
Next r
'if theres more the one record, include brackets for array
'if an array_label is given give the array a key and the array become the value
'then if the array is labeled with a key it should have braces unless specified otherwise
If r > 2 Or force_array Then
ajson = "[" & ajson & "]"
If array_label <> "" Then
ajson = """" & array_label & """:" & ajson
If Not strip_braces Then
ajson = "{" & ajson & "}"
End If
End If
Else
If strip_braces Then
ajson = Mid(ajson, 2, Len(ajson) - 2)
End If
End If
json_from_table_zb = ajson
End Function
Public Function SHTp_get_block(point As Range) As Variant()
SHTp_get_block = point.CurrentRegion
End Function
Sub frmListBoxHeader(ByRef hdr As MSForms.listbox, ByRef det As MSForms.listbox, ParamArray cols())
Dim i As Long
hdr.ColumnCount = det.ColumnCount
hdr.ColumnWidths = det.ColumnWidths
' add header elements
hdr.clear
hdr.AddItem
For i = 0 To UBound(cols, 1)
hdr.list(0, i) = cols(i)
Next i
' make it pretty
'body.ZOrder (1)
'lbHEAD.ZOrder (0)
hdr.SpecialEffect = fmSpecialEffectFlat
'hdr.BackColor = RGB(200, 200, 200)
'hdr.Height = 15
' align header to body (should be done last!)
hdr.width = det.width
hdr.Left = det.Left
hdr.Top = det.Top - (hdr.Height + 3)
End Sub
Public Function IntersectsWith(Range1 As Range, Range2 As Range) As Boolean
IntersectsWith = Not Application.Intersect(Range1, Range2) Is Nothing
End Function
Reference in New Issue View Git Blame Copy Permalink