2020-01-13 17:23:39 -05:00
Attribute VB_Name = "FL"
Option Explicit
Public price_sheet As Worksheet
Public x As New TheBigOne
2020-01-15 11:41:19 -05:00
Public Enum ColorTier
B_ase = 0
T_raditional = 1
principa_L = 2
pre_M_ium = 3
P_rogram = 4
C_ustom = 5
E_cogrow = 6
O_rganic = 7
W_axtough = 8
End Enum
2020-01-13 17:23:39 -05:00
Sub Determine_Active_Range ( )
Dim r As Range
Dim s As String
Dim cell As Range
Set r = Selection
MsgBox ( r . address )
For Each cell In r . Cells
s = s & cell . value
Next cell
MsgBox ( s )
End Sub
Sub Cross_Join_Selection ( )
Dim x As New TheBigOne
Dim r As Range
Dim ar As Range
Dim r1 ( ) As String
Dim r2 ( ) As String
Dim d ( ) As String
Dim i As Integer
Dim dest As String
Set r = Selection
i = 1
For Each ar In r . Areas
If i = 1 Then
r1 = x . SHTp_Get ( Excel . ActiveSheet . Name , ar . row , ar . column , False )
Else
r2 = x . SHTp_Get ( Excel . ActiveSheet . Name , ar . row , ar . column , False )
r1 = x . TBLp_CrossJoin ( r1 , r2 , True )
End If
i = i + 1
Next ar
2020-01-29 13:31:32 -05:00
2020-01-13 17:23:39 -05:00
dest = InputBox ( "Input row & column numbers like " "3,17" "" )
If dest = "" Then
Exit Sub
Else
d = Split ( dest , "," )
End If
Call x . SHTp_Dump ( r1 , Excel . ActiveSheet . Name , CLng ( d ( 0 ) ) , CLng ( d ( 1 ) ) , False , True )
End Sub
Sub BackupPersonal ( )
Application . DisplayAlerts = False
With Workbooks ( "Personal.xlsb" )
. SaveCopyAs Workbooks ( "Personal.xlsb" ) . Sheets ( "CONST" ) . Cells ( 1 , 2 )
. Save
End With
Application . DisplayAlerts = True
End Sub
Sub ExtractPNC_CSV ( )
Dim x As New TheBigOne
Dim f ( ) As String
Dim col ( ) As String
Dim coli As Long
Dim bal ( ) As String
Dim bali As Long
Dim sched_loan As String
Dim P As FileDialog
Dim i As Long
Dim j As Long
Dim m As Long
Dim k As Long
Dim row ( ) As String
Dim commit As Integer
Dim oblig As Integer
Dim sched As Integer
Dim loan As Integer
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
'--------Open file-------------
Set P = Application . FileDialog ( msoFileDialogOpen )
P . Show
'--------Extract text----------
f = x . FILEp_GetTXT ( P . SelectedItems ( 1 ) , 2000 )
'--------resize arrays---------
ReDim col ( 11 , UBound ( f , 2 ) )
ReDim bal ( 8 , UBound ( f , 2 ) )
coli = 1
bali = 1
j = 1
m = 1
'--------main interation-------
For i = 0 To UBound ( f , 2 )
sched = InStr ( f ( 0 , i ) , "Schedule" )
loan = InStr ( f ( 0 , i ) , "Loan" )
If sched < > 0 Then
row = x . TXTp_ParseCSVrow ( f , i + 2 , 0 )
col ( 0 , 0 ) = "Schedule#"
For k = 0 To 10
col ( k + 1 , 0 ) = row ( k )
Next k
sched_loan = x . TXTp_ParseCSVrow ( f , i + 1 , 0 ) ( 0 )
i = i + 3
commit = 0
oblig = 0
Do Until commit < > 0 Or oblig < > 0
row = x . TXTp_ParseCSVrow ( f , i , 0 )
col ( 0 , j ) = sched_loan
For k = 0 To 10
col ( k + 1 , j ) = row ( k )
Next k
j = j + 1
i = i + 1
commit = InStr ( f ( 0 , i ) , "Commitment" )
oblig = InStr ( f ( 0 , i ) , "Oblig" )
'---or end of file-----
Loop
sched = 0
ElseIf loan < > 0 Then
row = x . TXTp_ParseCSVrow ( f , i + 2 , 0 )
bal ( 0 , 0 ) = "Loan#"
For k = 0 To 7
bal ( k + 1 , 0 ) = row ( k )
Next k
sched_loan = x . TXTp_ParseCSVrow ( f , i + 1 , 0 ) ( 0 )
i = i + 3
commit = 0
oblig = 0
Do Until commit < > 0 Or oblig < > 0
row = x . TXTp_ParseCSVrow ( f , i , 0 )
bal ( 0 , m ) = sched_loan
For k = 0 To 7
bal ( k + 1 , m ) = row ( k )
Next k
m = m + 1
i = i + 1
If i > UBound ( f , 2 ) Then Exit Do
If f ( 0 , i ) = "" Then Exit Do
commit = InStr ( f ( 0 , i ) , "Commitment" )
oblig = InStr ( f ( 0 , i ) , "Oblig" )
'---or end of file-----
Loop
sched = 0
loan = 0
End If
Next i
ReDim Preserve col ( 11 , j - 2 )
ReDim Preserve bal ( 8 , m - 1 )
' Set wb = Workbooks.Add
' wb.Sheets.Add
' Set sh1 = wb.Sheets("Sheet1")
' Set sh2 = wb.Sheets("Sheet2")
' sh1.Name = "Collateral"
' sh2.Name = "Balance"
If Not x . FILEp_CreateCSV ( Mid ( P . SelectedItems ( 1 ) , 1 , Len ( P . SelectedItems ( 1 ) ) - 4 ) & "col.csv" , col ) Then
MsgBox ( "error" )
End If
If Not x . FILEp_CreateCSV ( Mid ( P . SelectedItems ( 1 ) , 1 , Len ( P . SelectedItems ( 1 ) ) - 4 ) & "bal.csv" , bal ) Then
MsgBox ( "error" )
End If
' Call x.SHTp_Dump(col, sh1.Name, 1, 1, True, True, 1, 4, 5, 6, 7, 8, 9, 10, 11)
' Call x.SHTp_Dump(bal, sh2.Name, 1, 1, True, True, 1, 2, 5, 6, 7, 8)
'
' sh1.range("A1").CurrentRegion.Columns.AutoFit
' sh2.range("A2").CurrentRegion.Columns.AutoFit
'
' If Not x.FILEp_CreateCSV("C:\users\ptrowbridge\downloads\col.csv", col) Then
' MsgBox ("error")
' End If
End Sub
Sub GrabBorrowHist ( )
Dim sh As Worksheet
Dim x As New TheBigOne
Dim i As Long
Dim b ( ) As String
Set sh = Application . ActiveSheet
b = x . SHTp_Get ( sh . Name , 3 , 1 , True )
Call x . TBLp_FilterSingle ( b , 14 , "" , False )
Call x . TBLp_DeleteCols ( b , x . ARRAYp_MakeInteger ( 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 ) )
Call x . TBLp_AddEmptyCol ( b )
Call x . TBLp_AddEmptyCol ( b )
For i = 1 To UBound ( b , 2 )
b ( 9 , i ) = ActiveSheet . Name
b ( 10 , i ) = ActiveWorkbook . Name
Next i
b ( 9 , 0 ) = "Tab"
b ( 10 , 0 ) = "File"
Application . Workbooks ( "PERSONAL.XLSB" ) . Activate
Set sh = Application . Workbooks ( "PERSONAL.XLSB" ) . Sheets ( "BORROW" )
i = 1
Do Until sh . Cells ( i , 1 ) = ""
i = i + 1
Loop
Call x . SHTp_Dump ( b , "BORROW" , i , 1 , False , True )
End Sub
Function fn_coln_colchar ( colnum As Long ) As String
fn_coln_colchar = colnum / 26
End Function
Sub add_quote_front ( )
Dim r As Range
Set r = Selection
Dim c As Object
For Each c In r . Cells
If c . value < > "" Then c . value = "'" & c . value
Next c
End Sub
Function json_from_list ( keys As Range , values As Range ) As String
Dim json As String
Dim i As Integer
Dim first_comma As Boolean
Dim needs_braces As Integer
Dim needs_comma As Boolean
needs_comma = False
needs_braces = 0
For i = 1 To keys . Cells . Count
If values . Cells ( i ) . value < > "" Then
needs_braces = needs_braces + 1
If needs_comma Then json = json & ","
needs_comma = True
If IsNumeric ( values . Cells ( i ) . value ) Then
json = json & Chr ( 34 ) & keys . Cells ( i ) . value & Chr ( 34 ) & ":" & values . Cells ( i ) . value
Else
json = json & Chr ( 34 ) & keys . Cells ( i ) . value & Chr ( 34 ) & ":" & Chr ( 34 ) & values . Cells ( i ) . value & Chr ( 34 )
End If
End If
Next i
If needs_braces > 0 Then json = "{" & json & "}"
json_from_list = json
End Function
Function json_nest ( key As String , json As String ) As String
json_nest = "{" "" & key & "" ":" & json & "}"
End Function
Function json_concat ( list As Range ) As String
Dim json As String
Dim i As Integer
i = 0
For Each cell In list
If cell . value < > "" Then
i = i + 1
If i = 1 Then
json = cell . value
Else
json = json & "," & cell . value
End If
End If
Next cell
If i > 1 Then json = "[" & json & "]"
json_concat = json
End Function
Sub json_from_table_pretty ( )
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl ( ) As Variant
Selection . CurrentRegion . Select
tbl = Selection
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 & "," & vbCrLf
needs_comma = True
If IsNumeric ( tbl ( r , c ) ) Then
json = json & Chr ( 34 ) & tbl ( 1 , c ) & Chr ( 34 ) & ":" & tbl ( r , c )
Else
json = json & Chr ( 34 ) & tbl ( 1 , c ) & Chr ( 34 ) & ":" & Chr ( 34 ) & tbl ( r , c ) & Chr ( 34 )
End If
End If
Next c
If needs_braces > 0 Then json = "{" & vbCrLf & json & vbCrLf & "}"
needs_comma = False
needs_braces = 0
If r > 2 Then
ajson = ajson & vbCrLf & "," & vbCrLf & json
Else
ajson = json
End If
json = ""
Next r
If r > 2 Then ajson = "[" & ajson & "]"
Call wapi . ClipBoard_SetData ( ajson )
End Sub
Sub json_from_table ( )
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl ( ) As Variant
Selection . CurrentRegion . Select
tbl = Selection
Call wapi . ClipBoard_SetData ( x . json_from_table ( tbl , "y" , False ) )
End Sub
2020-06-23 15:41:59 -04:00
Sub strip_goofy_char ( )
Dim tbl ( ) As Variant
Dim i As Long
Dim j As Long
Dim rx As Object
Dim strip_text As String
Dim strip_num As String
Dim strip_date As String
Set rx = CreateObject ( "vbscript.regexp" )
rx . Global = True
strip_text = "[^a-zA-Z0-9 \(\)\<\>\:\;\|\\\[\]\{\}\.\-\_\,\#\" "]"
strip_num = "[^0-9\.]"
strip_date = "[^0-9\/\-\:\.]"
rx . Pattern = strip_text
tbl = Selection
For i = 1 To UBound ( tbl , 1 )
For j = 1 To UBound ( tbl , 2 )
tbl ( i , j ) = rx . Replace ( tbl ( i , j ) , "" )
Next j
Next i
Selection . FormulaR1C1 = tbl
End Sub
2020-01-13 17:23:39 -05:00
Sub PastValues ( )
Attribute PastValues . VB_ProcData . VB_Invoke_Func = "V\n14"
On Error GoTo errh
Call Selection . PasteSpecial ( xlPasteValues , xlNone , False , False )
errh:
End Sub
Sub CollapsePvtItem ( )
Attribute CollapsePvtItem . VB_ProcData . VB_Invoke_Func = "Z\n14"
On Error GoTo show_det
ActiveCell . PivotItem . DrilledDown = False
On Error GoTo drill_down
ActiveCell . PivotItem . ShowDetail = False
show_det:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotItem . ShowDetail = False
Err . Number = 0
End If
drill_down:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotItem . DrilledDown = False
End If
errh:
End Sub
Sub ExpandPvtItem ( )
Attribute ExpandPvtItem . VB_ProcData . VB_Invoke_Func = "X\n14"
On Error GoTo show_det
ActiveCell . PivotItem . DrilledDown = True
On Error GoTo drill_down
ActiveCell . PivotItem . ShowDetail = True
show_det:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotItem . ShowDetail = True
Err . Number = 0
End If
drill_down:
On Error GoTo errh
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotItem . DrilledDown = True
End If
errh:
End Sub
Sub CollapsePvtFld ( )
Attribute CollapsePvtFld . VB_ProcData . VB_Invoke_Func = "A\n14"
On Error GoTo show_det
ActiveCell . PivotField . DrilledDown = False
On Error GoTo drill_down
ActiveCell . PivotField . ShowDetail = False
show_det:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotField . ShowDetail = False
Err . Number = 0
End If
drill_down:
On Error GoTo errh
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotField . DrilledDown = False
End If
errh:
End Sub
Sub ExpandPvtFld ( )
Attribute ExpandPvtFld . VB_ProcData . VB_Invoke_Func = "S\n14"
On Error GoTo show_det
ActiveCell . PivotField . DrilledDown = True
On Error GoTo drill_down
ActiveCell . PivotField . ShowDetail = True
show_det:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotField . ShowDetail = True
Err . Number = 0
End If
drill_down:
If Err . Number < > 0 Then
On Error GoTo errh
ActiveCell . PivotField . DrilledDown = True
End If
errh:
End Sub
Sub ColorMatrixExtract ( )
Dim s ( ) As String
Dim t ( ) As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim sh As Worksheet
Dim found As Boolean
ReDim s ( 1 , 10000 )
For Each sh In Sheets
If sh . Name = "Color Matrix" Then found = True
Next sh
If Not found Then Exit Sub
Set sh = Sheets ( "Color Matrix" )
If sh . Cells ( 5 , 1 ) < > "BASE WHITE" Then Exit Sub
m = 1
i = 1
s ( 0 , 0 ) = "COLOR ID"
s ( 1 , 0 ) = "DESCRIPTION"
Do
If sh . Cells ( 6 , i ) = "COLOR ID" Then
j = 1
Do Until sh . Cells ( 6 , i + j ) = "DESCRIPTION"
j = j + 1
Loop
k = 7
Do Until sh . Cells ( k , i ) = ""
s ( 0 , m ) = sh . Cells ( k , i )
s ( 1 , m ) = sh . Cells ( k , i + j )
k = k + 1
m = m + 1
Loop
End If
i = i + 1
If i = 500 Then Exit Do
Loop
ReDim Preserve s ( 1 , m - 1 )
Call x . SHTp_Dump ( s , "Extract" , 1 , 1 , True , True )
End Sub
Sub SetPivotShortcutKeys ( )
Call Application . MacroOptions ( "PERSONAL.xlsb!CollapsePvtFld" , "" , , , , "A" )
Call Application . MacroOptions ( "PERSONAL.xlsb!CollapsePvtItem" , "" , , , , "Z" )
Call Application . MacroOptions ( "PERSONAL.xlsb!ExpandPvtFld" , "" , , , , "S" )
Call Application . MacroOptions ( "PERSONAL.xlsb!ExpandPvtItem" , "" , , , , "X" )
End Sub
Sub LoadChan ( )
'if not x.ADOp_OpenCon(0,
End Sub
Sub markdown_from_table ( )
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim tbl ( ) As Variant
Selection . CurrentRegion . Select
tbl = Selection
Call wapi . ClipBoard_SetData ( x . markdown_from_table ( tbl ) )
End Sub
Sub json_multirange ( )
Dim wapi As New Windows_API
Dim x As New TheBigOne
Call wapi . ClipBoard_SetData ( x . json_multirange ( Selection ) )
End Sub
Sub markdown_whole_sheet ( )
Dim x As New TheBigOne
Dim wapi As New Windows_API
Call wapi . ClipBoard_SetData ( x . markdown_whole_sheet ( ActiveSheet ) )
End Sub
2020-01-29 13:31:32 -05:00
Sub sql_from_range_db2_qh ( )
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r ( ) As String
Selection . CurrentRegion . Select
Call wapi . ClipBoard_SetData ( x . SQLp_build_sql_values ( x . ARRAYp_get_range_string ( Selection ) , True , True , Db2 , True ) )
End Sub
Sub sql_from_range_db2_noqh ( )
2020-01-13 17:23:39 -05:00
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r ( ) As String
Selection . CurrentRegion . Select
2020-01-29 13:31:32 -05:00
Call wapi . ClipBoard_SetData ( x . SQLp_build_sql_values ( x . ARRAYp_get_range_string ( Selection ) , True , True , Db2 , False ) )
End Sub
Sub sql_from_range_pg_qh ( )
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r ( ) As String
Selection . CurrentRegion . Select
Call wapi . ClipBoard_SetData ( x . SQLp_build_sql_values ( x . ARRAYp_get_range_string ( Selection ) , True , True , PostgreSQL , True ) )
End Sub
Sub sql_from_range_pg_noqh ( )
Dim x As New TheBigOne
Dim wapi As New Windows_API
Dim r ( ) As String
Selection . CurrentRegion . Select
Call wapi . ClipBoard_SetData ( x . SQLp_build_sql_values ( x . ARRAYp_get_range_string ( Selection ) , True , True , PostgreSQL , False ) )
2020-01-13 17:23:39 -05:00
End Sub
Sub auto_fit_range ( )
Selection . CurrentRegion . Columns . AutoFit
End Sub
Sub pivot_field_format ( )
Attribute pivot_field_format . VB_ProcData . VB_Invoke_Func = "F\n14"
ActiveSheet . PivotTables ( 1 ) . PivotFields ( ActiveCell . value ) . NumberFormat = "_(* #,##0_);_(* (#,##0);_(* " "-" "_);_(@_)"
End Sub
2020-06-23 15:41:59 -04:00
Sub pivot_field_format_3dec ( )
Attribute pivot_field_format_3dec . VB_ProcData . VB_Invoke_Func = "N\n14"
ActiveSheet . PivotTables ( 1 ) . PivotFields ( ActiveCell . value ) . NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* " "-" "???_);_(@_)"
End Sub
2020-01-13 17:23:39 -05:00
Sub Write_selection ( )
Dim P As FileDialog
'--------Open file-------------
Set P = Application . FileDialog ( msoFileDialogSaveAs )
P . Show
Call x . FILEp_CreateTXT ( P . SelectedItems ( 1 ) , x . SHTp_Get ( ActiveSheet . Name , Selection . row , Selection . column , False ) )
End Sub
Sub dump_markdown ( )
Dim path As String
Dim s As Worksheet
Dim x As New TheBigOne
Dim wapi As New Windows_API
path = ActiveWorkbook . path & "\" & Mid ( ActiveWorkbook . Name , 1 , InStr ( 1 , ActiveWorkbook . Name , ".xl" ) ) & "md"
For Each s In ActiveWorkbook . Worksheets
Call wapi . ClipBoard_SetData ( x . markdown_whole_sheet ( s ) )
Next s
End Sub
Sub test ( )
Dim c As New WindCrypt
c . Password = "hi"
c . InBuffer = "test"
Call c . Validate
End Sub
Sub split_forecast_data ( )
Application . EnableCancelKey = xlDisabled
Dim wb As Workbook
Dim ws As Worksheet
Dim d ( ) As String
Dim u ( ) As String
Dim f ( ) As String
Dim i As Long
d = x . SHTp_Get ( "Data" , 1 , 1 , True )
u = d
Call x . TBLp_Aggregate ( u , False , True , True , Array ( 1 ) , Array ( "S" ) , Array ( 5 , 6 , 7 , 8 ) )
For i = 1 To UBound ( u , 2 )
Call Sheets ( "TEMPLATE" ) . Copy ( Sheets ( i ) )
Set ws = Sheets ( i )
ws . Name = Left ( RTrim ( u ( 0 , i ) ) , 20 )
f = d
Call x . TBLp_FilterSingle ( f , 1 , u ( 0 , i ) , True )
Call x . SHTp_Dump ( f , ws . Name , 3 , 12 , False , True , 16 , 17 , 18 , 19 )
Next i
End Sub
Function range_empty ( ByRef r As Range ) As Boolean
Dim c As Range
range_empty = True
For Each c In r . Cells
If Not IsEmpty ( c . value ) Then
range_empty = False
Exit Function
End If
Next c
End Function
Function build_monthly ( ByRef part As String , billto_group As String , month As String , vol As Double , amt As Double ) As String
Dim j As Object
Set j ( "part" ) = part
Set j ( "billto_group" ) = billto_group
Set j ( "month" ) = month
Set j ( "part" ) = vol
Set j ( "part" ) = amt
build_monthly = JsonConverter . ConvertToJson ( j )
End Function
Sub extract_price_matrix ( )
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl ( ) As Variant
Dim unp ( ) As String
Dim unps ( ) As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim cms_pl ( ) As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
'------------------------------------selection-------------------------------------------------
Set orig = Application . Selection
Selection . CurrentRegion . Select
Set orig = Application . Selection
'--------------------------------test if valid price matrix------------------------------
If Selection . Cells . Count = 1 Then
MsgBox ( "selection is not a table" )
orig . Select
Exit Sub
End If
tbl = Selection
If UBound ( tbl , 1 ) < 4 Then error = "selection is not a valid price matrix"
If UBound ( tbl , 2 ) < 2 Then error = "selection is not a valid price matrix"
If Not error = "" Then
MsgBox ( error )
Exit Sub
End If
'-----------------------------unpivot price matrix into new array-----------------------------
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
2020-01-15 11:41:19 -05:00
ReDim unp ( 8 , ( UBound ( tbl , 2 ) - 1 ) * ( UBound ( tbl , 1 ) - 4 ) )
For i = 5 To UBound ( tbl , 1 )
2020-01-13 17:23:39 -05:00
For j = 2 To UBound ( tbl , 2 )
k = k + 1
'part
unp ( 0 , k ) = tbl ( i , 1 )
'copy headers down the left
2020-01-15 11:41:19 -05:00
unp ( 1 , k ) = tbl ( 1 , j ) 'color code/tier (row one, column j)
unp ( 2 , k ) = tbl ( 2 , j ) 'size code (row two, column j)
unp ( 3 , k ) = tbl ( 3 , j ) 'volue break uom (row 3, column j)
unp ( 4 , k ) = Format ( tbl ( 4 , j ) , "#.00" ) 'volue break qty (row 4, column j)
unp ( 5 , k ) = "M" 'pricing unit of measuer
unp ( 6 , k ) = Format ( tbl ( i , j ) , "#.00" ) 'price (row i, column j)
unp ( 7 , k ) = i
unp ( 8 , k ) = j
2020-01-13 17:23:39 -05:00
Next j
Next i
unp ( 0 , 0 ) = "mold"
unp ( 1 , 0 ) = "sizc"
2020-01-15 11:41:19 -05:00
unp ( 2 , 0 ) = "color"
unp ( 3 , 0 ) = "vbuom"
unp ( 4 , 0 ) = "vbqty"
unp ( 5 , 0 ) = "puom"
unp ( 6 , 0 ) = "price"
unp ( 7 , 0 ) = "orig_row"
unp ( 8 , 0 ) = "orig_col"
If Not x . TBLp_TestNumeric ( unp , 4 ) Then
2020-01-13 17:23:39 -05:00
MsgBox ( "volume break quantity is text" )
Exit Sub
End If
2020-01-15 11:41:19 -05:00
If Not x . TBLp_TestNumeric ( unp , 6 ) Then
2020-01-13 17:23:39 -05:00
MsgBox ( "price is text" )
Exit Sub
End If
'-------------------------prepare sql to upload---------------------------------------------------------------
2020-01-29 13:31:32 -05:00
sql = x . SQLp_build_sql_values ( unp , False , True , Db2 , False )
2020-01-13 17:23:39 -05:00
sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA"
Call wapi . ClipBoard_SetData ( sql )
If MsgBox ( sql , vbOKCancel , "continue with build?" ) = vbCancel Then Exit Sub
login . Show
If Not login . proceed Then Exit Sub
If Not x . ADOp_OpenCon ( 0 , ISeries , "S7830956" , False , login . tbU . Text , login . tbP . Text ) Then
MsgBox ( "not able to connect to CMS" & vbCrLf & x . ADOo_errstring )
Exit Sub
End If
If Not x . ADOp_Exec ( 0 , sql ) Then
MsgBox ( x . ADOo_errstring )
Call x . ADOp_CloseCon ( 0 )
Exit Sub
End If
'-------------------call price build procedure--------------------------------------------------------
cms_pl = x . ADOp_SelectS ( 0 , "CALL rlarp.build_pricelist" , True , 25000 , True )
Call x . ADOp_CloseCon ( 0 )
If x . ADOo_errstring < > "" Then
MsgBox ( x . ADOo_errstring )
Exit Sub
End If
'--------------------------setup an output sheet if necessary-------------------------------
For Each ws In Application . Worksheets
For Each cp In ws . CustomProperties
If cp . Name = "spec_name" And cp . value = "price_list" Then
Set new_sh = ws
End If
Next cp
Next ws
If new_sh Is Nothing Then
Set new_sh = Application . Worksheets . Add
Call new_sh . CustomProperties . Add ( "spec_name" , "price_list" )
End If
'-------------------------dump contents------------------------------------------------------
Call x . SHTp_Dump ( cms_pl , new_sh . Name , 1 , 1 , True , True )
new_sh . Select
ActiveSheet . Cells ( 1 , 1 ) . CurrentRegion . Select
Selection . Columns . AutoFit
Rows ( "1:1" ) . Select
With ActiveWindow
. SplitColumn = 0
. SplitRow = 1
End With
ActiveWindow . FreezePanes = True
'--------------------------format source cells for any build issues--------------------------------
orig . Worksheet . Select
With orig . Interior
. Pattern = xlNone
. TintAndShade = 0
. PatternTintAndShade = 0
End With
For i = 1 To UBound ( cms_pl , 1 )
2020-01-15 17:17:07 -05:00
Select Case cms_pl ( i , 13 )
2020-01-13 17:23:39 -05:00
Case ""
Case "no unit conversion"
2020-01-15 17:17:07 -05:00
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . Color = RGB ( 255 , 255 , 161 )
2020-01-13 17:23:39 -05:00
Case "no part number"
2020-06-23 15:41:59 -04:00
'orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
2020-01-13 17:23:39 -05:00
End Select
Next i
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
End Sub
2020-06-23 15:41:59 -04:00
Sub extract_price_matrix_r1 ( )
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl ( ) As Variant
Dim unp ( ) As String
Dim unps ( ) As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim cms_pl ( ) As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
'------------------------------------selection-------------------------------------------------
Set orig = Application . Selection
Selection . CurrentRegion . Select
Set orig = Application . Selection
'--------------------------------test if valid price matrix------------------------------
If Selection . Cells . Count = 1 Then
MsgBox ( "selection is not a table" )
orig . Select
Exit Sub
End If
tbl = Selection
If UBound ( tbl , 1 ) < 4 Then error = "selection is not a valid price matrix"
If UBound ( tbl , 2 ) < 2 Then error = "selection is not a valid price matrix"
If Not error = "" Then
MsgBox ( error )
Exit Sub
End If
'-----------------------------unpivot price matrix into new array-----------------------------
Dim i As Long
Dim j As Long
Dim k As Long
k = 0
ReDim unp ( 8 , ( UBound ( tbl , 2 ) - 2 ) * ( UBound ( tbl , 1 ) - 3 ) )
For i = 4 To UBound ( tbl , 1 )
For j = 3 To UBound ( tbl , 2 )
k = k + 1
'part
unp ( 0 , k ) = tbl ( i , 1 )
'copy headers down the left
unp ( 1 , k ) = tbl ( 1 , j ) 'size code (row two, column j)
unp ( 2 , k ) = tbl ( i , 2 ) 'color code/tier (row one, column j)
unp ( 3 , k ) = tbl ( 2 , j ) 'volue break uom (row 3, column j)
unp ( 4 , k ) = Format ( tbl ( 3 , j ) , "#.00" ) 'volue break qty (row 4, column j)
unp ( 5 , k ) = "M" 'pricing unit of measuer
unp ( 6 , k ) = Format ( tbl ( i , j ) , "#.00" ) 'price (row i, column j)
unp ( 7 , k ) = i
unp ( 8 , k ) = j
Next j
Next i
unp ( 0 , 0 ) = "mold"
unp ( 1 , 0 ) = "sizc"
unp ( 2 , 0 ) = "color"
unp ( 3 , 0 ) = "vbuom"
unp ( 4 , 0 ) = "vbqty"
unp ( 5 , 0 ) = "puom"
unp ( 6 , 0 ) = "price"
unp ( 7 , 0 ) = "orig_row"
unp ( 8 , 0 ) = "orig_col"
If Not x . TBLp_TestNumeric ( unp , 4 ) Then
MsgBox ( "volume break quantity is text" )
Exit Sub
End If
If Not x . TBLp_TestNumeric ( unp , 6 ) Then
MsgBox ( "price is text" )
Exit Sub
End If
'-------------------------prepare sql to upload---------------------------------------------------------------
sql = x . SQLp_build_sql_values ( unp , False , True , Db2 , False )
sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA"
Call wapi . ClipBoard_SetData ( sql )
If MsgBox ( sql , vbOKCancel , "continue with build?" ) = vbCancel Then Exit Sub
login . Show
If Not login . proceed Then Exit Sub
If Not x . ADOp_OpenCon ( 0 , ISeries , "S7830956" , False , login . tbU . Text , login . tbP . Text ) Then
MsgBox ( "not able to connect to CMS" & vbCrLf & x . ADOo_errstring )
Exit Sub
End If
If Not x . ADOp_Exec ( 0 , sql ) Then
MsgBox ( x . ADOo_errstring )
Call x . ADOp_CloseCon ( 0 )
Exit Sub
End If
'-------------------call price build procedure--------------------------------------------------------
cms_pl = x . ADOp_SelectS ( 0 , "CALL rlarp.build_pricelist" , True , 25000 , True )
Call x . ADOp_CloseCon ( 0 )
If x . ADOo_errstring < > "" Then
MsgBox ( x . ADOo_errstring )
Exit Sub
End If
'--------------------------setup an output sheet if necessary-------------------------------
For Each ws In Application . Worksheets
For Each cp In ws . CustomProperties
If cp . Name = "spec_name" And cp . value = "price_list" Then
Set new_sh = ws
Exit For
End If
Next cp
Next ws
If new_sh Is Nothing Then
Set new_sh = Application . Worksheets . Add
Call new_sh . CustomProperties . Add ( "spec_name" , "price_list" )
End If
'-------------------------dump contents------------------------------------------------------
Call x . SHTp_Dump ( cms_pl , new_sh . Name , 1 , 1 , True , True )
new_sh . Select
ActiveSheet . Cells ( 1 , 1 ) . CurrentRegion . Select
Selection . Columns . AutoFit
Rows ( "1:1" ) . Select
With ActiveWindow
. SplitColumn = 0
. SplitRow = 1
End With
ActiveWindow . FreezePanes = True
'--------------------------format source cells for any build issues--------------------------------
orig . Worksheet . Select
With orig . Interior
. Pattern = xlNone
. TintAndShade = 0
. PatternTintAndShade = 0
End With
'if a cell has even one valid hit, don't show an error
2020-07-14 16:06:44 -04:00
'create a copy of tbl
'the default value for cell is error, if any good values are found, they stay
For i = 1 To UBound ( cms_pl , 1 )
Select Case cms_pl ( i , 13 )
Case ""
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor = xlThemeColorAccent6
Case "no unit conversion"
If orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor < > xlThemeColorAccent6 Then
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . Color = RGB ( 255 , 255 , 161 )
End If
Case "no part number"
If orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor < > xlThemeColorAccent6 Then
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . Color = RGB ( 255 , 255 , 161 )
End If
End Select
Next i
Dim cell As Range
For Each cell In Application . Selection . Cells
'if the cell fill is green, then a known good part was found, so cell to blank
If cell . Interior . ThemeColor = xlThemeColorAccent6 Then
cell . Interior . Pattern = xlNone
Else
If cell . Interior . Pattern = xlNone And cell . value < > "" Then
cell . Interior . Color = RGB ( 255 , 255 , 161 )
End If
End If
'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed
Next cell
Selection . Columns ( 1 ) . Interior . Pattern = xlNone
Selection . Columns ( 2 ) . Interior . Pattern = xlNone
Selection . Rows ( 1 ) . Interior . Pattern = xlNone
Selection . Rows ( 2 ) . Interior . Pattern = xlNone
Selection . Rows ( 3 ) . Interior . Pattern = xlNone
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
End Sub
Sub extract_price_matrix_r2 ( )
'------------------------------------setup-------------------------------------------------
Dim wapi As New Windows_API
Dim x As New TheBigOne
Dim tbl ( ) As Variant
Dim unp ( ) As String
Dim unv ( ) As Variant
Dim unps ( ) As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim cms_pl ( ) As String
Dim pw As String
Dim new_sh As Worksheet
Dim ws As Worksheet
Dim cp As CustomProperty
'------------------------------------selection-------------------------------------------------
Set orig = Application . Selection
Selection . CurrentRegion . Select
Set orig = Application . Selection
'--------------------------------test if valid price matrix------------------------------
If Selection . Cells . Count = 1 Then
MsgBox ( "selection is not a table" )
orig . Select
Exit Sub
End If
tbl = Selection
If UBound ( tbl , 1 ) < 2 Then error = "selection is not a valid price matrix"
If UBound ( tbl , 2 ) < 9 Then error = "selection is not a valid price matrix"
If Not error = "" Then
MsgBox ( error )
Exit Sub
End If
'-----------------------------unpivot price matrix into new array-----------------------------
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
k = 0
ReDim unp ( 9 , ( UBound ( tbl , 1 ) - 1 ) * 3 )
'iterate through rows
For i = 2 To UBound ( tbl , 1 )
'3 iterations per row
For m = 0 To 2
k = k + 1
'part
unp ( 0 , k ) = tbl ( i , 1 ) 'stlye code
unp ( 1 , k ) = tbl ( i , 2 ) 'color tier
unp ( 2 , k ) = tbl ( i , 3 ) 'branding
unp ( 3 , k ) = tbl ( i , 4 ) 'kit
unp ( 4 , k ) = tbl ( i , 5 ) 'suffix
unp ( 5 , k ) = tbl ( i , 6 ) 'container
unp ( 6 , k ) = m + 1 'volume break
unp ( 7 , k ) = tbl ( i , 7 + m ) 'price
unp ( 8 , k ) = i 'orig row
unp ( 9 , k ) = j + m 'orig col
Next m
Next i
unp ( 0 , 0 ) = "stlc"
unp ( 1 , 0 ) = "coltier"
unp ( 2 , 0 ) = "branding"
unp ( 3 , 0 ) = "kit"
unp ( 4 , 0 ) = "suffix"
unp ( 5 , 0 ) = "container"
unp ( 6 , 0 ) = "volume"
unp ( 7 , 0 ) = "price"
unp ( 8 , 0 ) = "orig_row"
unp ( 9 , 0 ) = "orig_col"
If Not x . TBLp_TestNumeric ( unp , 7 ) Then
MsgBox ( "price is text" )
Exit Sub
End If
unp = x . TBLp_Transpose ( unp )
unv = x . TBLp_StringToVar ( unp )
'-------------------------prepare sql to upload---------------------------------------------------------------
'sql = x.SQLp_build_sql_values(unp, False, True, Db2, False)
sql = x . json_from_table ( unv , "" , False )
sql = "SELECT * FROM rlarp.build_pricelist_r1($$" & sql & "$$::jsonb)"
Call wapi . ClipBoard_SetData ( sql )
If MsgBox ( sql , vbOKCancel , "continue with build?" ) = vbCancel Then Exit Sub
login . Show
If Not login . proceed Then Exit Sub
If Not x . ADOp_OpenCon ( 0 , PostgreSQLODBC , "usmidlnx01" , False , login . tbU . Text , login . tbP . Text , "Port=5030;Database=ubm" ) Then
MsgBox ( "not able to connect to CMS" & vbCrLf & x . ADOo_errstring )
Exit Sub
End If
cms_pl = x . ADOp_SelectS ( 0 , sql , True , 50000 , True )
Call x . ADOp_CloseCon ( 0 )
'--------------------------setup an output sheet if necessary-------------------------------
For Each ws In Application . Worksheets
For Each cp In ws . CustomProperties
If cp . Name = "spec_name" And cp . value = "price_list" Then
Set new_sh = ws
Exit For
End If
Next cp
Next ws
If new_sh Is Nothing Then
Set new_sh = Application . Worksheets . Add
Call new_sh . CustomProperties . Add ( "spec_name" , "price_list" )
End If
'-------------------------dump contents------------------------------------------------------
Call x . SHTp_Dump ( cms_pl , new_sh . Name , 1 , 1 , True , True )
new_sh . Select
ActiveSheet . Cells ( 1 , 1 ) . CurrentRegion . Select
Selection . Columns . AutoFit
Rows ( "1:1" ) . Select
With ActiveWindow
. SplitColumn = 0
. SplitRow = 1
End With
ActiveWindow . FreezePanes = True
'--------------------------format source cells for any build issues--------------------------------
orig . Worksheet . Select
Exit Sub
With orig . Interior
. Pattern = xlNone
. TintAndShade = 0
. PatternTintAndShade = 0
End With
'if a cell has even one valid hit, don't show an error
2020-06-23 15:41:59 -04:00
'create a copy of tbl
'the default value for cell is error, if any good values are found, they stay
For i = 1 To UBound ( cms_pl , 1 )
Select Case cms_pl ( i , 13 )
Case ""
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor = xlThemeColorAccent6
Case "no unit conversion"
If orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor < > xlThemeColorAccent6 Then
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . Color = RGB ( 255 , 255 , 161 )
End If
Case "no part number"
If orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . ThemeColor < > xlThemeColorAccent6 Then
orig . Worksheet . Cells ( orig . row + cms_pl ( i , 14 ) - 1 , orig . column + cms_pl ( i , 15 ) - 1 ) . Interior . Color = RGB ( 255 , 255 , 161 )
End If
End Select
Next i
Dim cell As Range
For Each cell In Application . Selection . Cells
'if the cell fill is green, then a known good part was found, so cell to blank
If cell . Interior . ThemeColor = xlThemeColorAccent6 Then
cell . Interior . Pattern = xlNone
Else
If cell . Interior . Pattern = xlNone And cell . value < > "" Then
cell . Interior . Color = RGB ( 255 , 255 , 161 )
End If
End If
'if at this point the cell has no background, then there is no part, so highlight it, but only if a price is listed
Next cell
Selection . Columns ( 1 ) . Interior . Pattern = xlNone
Selection . Columns ( 2 ) . Interior . Pattern = xlNone
Selection . Rows ( 1 ) . Interior . Pattern = xlNone
Selection . Rows ( 2 ) . Interior . Pattern = xlNone
Selection . Rows ( 3 ) . Interior . Pattern = xlNone
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
End Sub
2020-01-13 17:23:39 -05:00
Sub go_to_price_issue ( )
Dim ws As Worksheet
Dim cp As CustomProperty
Dim orig As Range
Dim trow As Long
Dim tcol As Long
Dim i As Long
2020-01-29 13:31:32 -05:00
Dim has_Pricesheet As Boolean
2020-01-13 17:23:39 -05:00
2020-01-29 13:31:32 -05:00
has_Pricesheet = False
2020-01-13 17:23:39 -05:00
For Each ws In Application . Worksheets
For Each cp In ws . CustomProperties
If cp . Name = "spec_name" And cp . value = "price_list" Then
Set price_sheet = ws
2020-01-29 13:31:32 -05:00
has_Pricesheet = True
2020-01-13 17:23:39 -05:00
End If
Next cp
Next ws
2020-01-29 13:31:32 -05:00
If Not has_Pricesheet Then
MsgBox ( "no price sheet found" )
Exit Sub
End If
2020-01-13 17:23:39 -05:00
Set orig = Application . Selection
Selection . CurrentRegion . Select
trow = orig . row - Selection . row + 1
tcol = orig . column - Selection . column + 1
2020-01-15 11:41:19 -05:00
orig . Select
2020-01-13 17:23:39 -05:00
i = 1
Do Until price_sheet . Cells ( i , 1 ) = ""
2020-01-15 17:17:07 -05:00
If price_sheet . Cells ( i , 15 ) = trow And price_sheet . Cells ( i , 16 ) = tcol And price_sheet . Cells ( i , 14 ) < > "" Then
2020-01-13 17:23:39 -05:00
price_sheet . Select
2020-01-15 17:17:07 -05:00
ActiveSheet . Cells ( i , 14 ) . Select
2020-01-13 17:23:39 -05:00
Exit Sub
End If
i = i + 1
Loop
End Sub
Sub build_price_upload ( )
Dim x As New TheBigOne
Dim pl ( ) As String
Dim i As Long
Dim j As Long
Dim ul ( ) As String
Dim pl_code As String
Dim pl_action As String
2020-06-23 15:41:59 -04:00
Dim dtl_action As String
2020-01-13 17:23:39 -05:00
Dim pl_d1 As String
Dim pl_d2 As String
Dim pl_d3 As String
Dim fd As FileDialog
2020-06-25 16:58:13 -04:00
Dim ulsql As String
Dim temp ( ) As String
2020-01-13 17:23:39 -05:00
pl = x . SHTp_GetString ( Selection )
ReDim ul ( 11 , UBound ( pl , 2 ) )
PRICELIST_SHOW:
pricelist . Show
2020-06-25 16:58:13 -04:00
If Not pricelist . proceed Then Exit Sub
pl_code = pricelist . cbLIST . value
2020-01-13 17:23:39 -05:00
pl_d1 = pricelist . tbD1 . Text
pl_d2 = pricelist . tbD2 . Text
pl_d3 = pricelist . tbD3 . Text
2020-06-23 15:41:59 -04:00
pl_action = Mid ( pricelist . cbHDR . value , 1 , 1 )
dtl_action = Mid ( pricelist . cbDTL . value , 1 , 1 )
2020-01-13 17:23:39 -05:00
2020-06-25 16:58:13 -04:00
If Len ( pricelist . cbLIST . value ) > 5 Then
2020-01-13 17:23:39 -05:00
MsgBox ( "price code must be 5 or less characters" )
GoTo PRICELIST_SHOW
End If
2020-01-15 17:17:07 -05:00
If Not pricelist . cbInactive Then
Call x . TBLp_FilterSingle ( pl , 11 , "I" , False )
End If
If Not pricelist . cbNonStocked Then
Call x . TBLp_FilterSingle ( pl , 10 , "A" , True )
End If
2020-06-25 16:58:13 -04:00
'need to get the current list of products and if they already exist for the target price list
'target price list
'target part
'target volume level
ulsql = FL . x . SQLp_build_sql_values ( pl , True , True , Db2 , False )
ulsql = "DECLARE GLOBAL TEMPORARY TABLE session.plb AS (" & ulsql & ") WITH DATA"
If login . tbP . Text = "" Then
login . Show
If Not login . proceed Then
Exit Sub
End If
End If
If Not FL . x . ADOp_Exec ( 0 , ulsql , 1 , True , ISeries , "S7830956" , False , login . tbU . Text , login . tbP . Text ) Then
MsgBox ( FL . x . ADOo_errstring )
Exit Sub
End If
pl = FL . x . ADOp_SelectS ( 0 , "SELECT p.*, CASE WHEN COALESCE(c.jcpart,'') = '' THEN '1' ELSE '2' END flag FROM Session.plb P LEFT OUTER JOIN lgdat.iprcc c ON c.jcpart = P.Item AND c.JCPLCD = '" & pl_code & "' AND c.JCVOLL = p.vbqty * cast(p.num as float) / cast(p.den as float)" , True , 10000 , True )
If Not FL . x . ADOp_Exec ( 0 , "DROP TABLE SESSION.PLB" , 1 , True , ISeries , "S7830956" , False , login . tbU . Text , login . tbP . Text ) Then
MsgBox ( FL . x . ADOo_errstring )
Exit Sub
End If
Call FL . x . ADOp_CloseCon ( 0 )
2020-01-13 17:23:39 -05:00
ul ( 0 , 0 ) = "HDR"
ul ( 1 , 0 ) = pl_action
ul ( 2 , 0 ) = pl_code
ul ( 3 , 0 ) = Left ( pl_d1 , 30 )
ul ( 4 , 0 ) = Left ( pl_d2 , 30 )
ul ( 5 , 0 ) = Left ( pl_d3 , 30 )
ul ( 6 , 0 ) = "Y"
ul ( 7 , 0 ) = "N"
2020-01-15 11:41:19 -05:00
j = 0
2020-01-13 17:23:39 -05:00
For i = LBound ( pl , 2 ) + 1 To UBound ( pl , 2 )
2020-01-15 17:17:07 -05:00
'if there is no [uom, part#, price], don't create a row
2020-06-25 16:58:13 -04:00
If pl ( 11 , i ) < > "" And pl ( 12 , i ) < > "" And pl ( 7 , i ) < > "" And pl ( 8 , i ) < > "" Then
2020-01-15 11:41:19 -05:00
j = j + 1
2020-01-15 17:17:07 -05:00
ul ( 0 , j ) = "DTL" 'DTL
ul ( 1 , j ) = pl_code 'Price list code
2020-06-25 16:58:13 -04:00
ul ( 2 , j ) = pl ( 8 , i ) 'part number
ul ( 3 , j ) = pl ( 6 , i ) 'price unit
ul ( 4 , j ) = Format ( CDbl ( pl ( 5 , i ) ) * CDbl ( pl ( 11 , i ) ) / CDbl ( pl ( 12 , i ) ) , "0.00" ) 'volume break in price uom
ul ( 5 , j ) = Format ( pl ( 7 , i ) , "0.00" ) 'price
ul ( 11 , j ) = pl ( 17 , i ) 'add, update, delete
2020-01-15 11:41:19 -05:00
End If
2020-01-13 17:23:39 -05:00
Next i
2020-01-15 11:41:19 -05:00
ReDim Preserve ul ( 11 , j )
2020-01-15 17:17:07 -05:00
2020-01-13 17:23:39 -05:00
'--------Open file-------------
2020-06-25 16:58:13 -04:00
If Not x . FILEp_CreateCSV ( pricelist . tbPATH . Text & "\" & Replace ( pl_code , "." , "_" ) & ".csv" , ul ) Then
2020-01-13 17:23:39 -05:00
MsgBox ( "error" )
End If
2020-06-25 16:58:13 -04:00
Excel . Workbooks . Open ( pricelist . tbPATH . Text & "\" & Replace ( pl_code , "." , "_" ) & ".csv" )
2020-01-13 17:23:39 -05:00
'---------------------header row---------------------------------
End Sub
2020-06-23 15:41:59 -04:00