1649 lines
47 KiB
QBasic
1649 lines
47 KiB
QBasic
Attribute VB_Name = "FL"
|
|
|
|
Option Explicit
|
|
|
|
Public price_sheet As Worksheet
|
|
Public x As New TheBigOne
|
|
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
|
|
|
|
|
|
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
|
|
Dim idest As Range
|
|
|
|
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
|
|
|
|
Set idest = Excel.Application.InputBox("select the output cell", , , , , , , 8)
|
|
|
|
If idest Is Nothing Then
|
|
Exit Sub
|
|
End If
|
|
|
|
Call x.SHTp_Dump(r1, Excel.ActiveSheet.Name, idest.row, idest.column, 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
|
|
|
|
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
|
|
|
|
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 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 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
|
|
|
|
|
|
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()
|
|
|
|
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, 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))
|
|
|
|
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
|
|
|
|
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
|
|
|
|
Sub pivot_field_format_1dec()
|
|
Attribute pivot_field_format_1dec.VB_ProcData.VB_Invoke_Func = "M\n14"
|
|
|
|
ActiveSheet.PivotTables(1).PivotFields(ActiveCell.value).NumberFormat = "_(* #,##0.0_);_(* (#,##0.0);_(* ""-""???_);_(@_)"
|
|
|
|
End Sub
|
|
|
|
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 unv() As Variant
|
|
Dim unps() As String
|
|
Dim sql As String
|
|
Dim error As String
|
|
Dim orig As Range
|
|
Dim ini 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 ini = 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) <> 8 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(8, (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(4, k) = tbl(i, 5) 'container
|
|
unp(5, k) = m + 1 'volume break
|
|
unp(6, k) = tbl(i, 6 + m) 'price
|
|
unp(7, k) = i 'orig row
|
|
unp(8, k) = 6 + m 'orig col
|
|
Next m
|
|
Next i
|
|
unp(0, 0) = "stlc"
|
|
unp(1, 0) = "coltier"
|
|
unp(2, 0) = "branding"
|
|
unp(3, 0) = "accs"
|
|
'unp(4, 0) = "suffix"
|
|
unp(4, 0) = "container"
|
|
unp(5, 0) = "volume"
|
|
unp(6, 0) = "price"
|
|
unp(7, 0) = "orig_row"
|
|
unp(8, 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_f20($$" & sql & "$$::jsonb)"
|
|
Call wapi.ClipBoard_SetData(sql)
|
|
|
|
'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
|
|
'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")
|
|
new_sh.Name = "Price Build"
|
|
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
|
|
'create a copy of tbl
|
|
'the default value for cell is error, if any good values are found, they stay
|
|
|
|
j = 0
|
|
For i = 1 To UBound(cms_pl, 1)
|
|
Select Case cms_pl(i, 14)
|
|
Case ""
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.ThemeColor = xlThemeColorAccent6
|
|
Case "No UOM Conversion"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.Color = RGB(255, 255, 161)
|
|
End If
|
|
Case "Inactive"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.Color = RGB(255, 20, 161)
|
|
End If
|
|
Case "No SKU"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 12) - 1, orig.column + cms_pl(i, 13) - 1).Interior.Color = RGB(20, 255, 161)
|
|
End If
|
|
End Select
|
|
'if the current row/column is OK, advance to the next row/column
|
|
j = 0
|
|
Do Until cms_pl(i, 12) <> cms_pl(i + j, 12) Or cms_pl(i, 13) <> cms_pl(i + j, 13)
|
|
j = j + 1
|
|
If i + j >= UBound(cms_pl, 1) Then Exit Do
|
|
Loop
|
|
i = i + j - 1 '-1 becuase the "next i" will increment by 1 again
|
|
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.Columns(3).Interior.Pattern = xlNone
|
|
Selection.Columns(4).Interior.Pattern = xlNone
|
|
Selection.Columns(5).Interior.Pattern = xlNone
|
|
'Selection.Columns(6).Interior.Pattern = xlNone
|
|
Selection.Rows(1).Interior.Pattern = xlNone
|
|
|
|
|
|
'----------------------------cleanup-------------------------------------------------------------
|
|
|
|
Set x = Nothing
|
|
|
|
ini.Select
|
|
|
|
|
|
End Sub
|
|
|
|
Sub extract_price_matrix_suff()
|
|
|
|
'------------------------------------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 ini 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 ini = 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) = 7 + m 'orig col
|
|
Next m
|
|
Next i
|
|
unp(0, 0) = "stlc"
|
|
unp(1, 0) = "coltier"
|
|
unp(2, 0) = "branding"
|
|
unp(3, 0) = "accs"
|
|
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_f20_suff($$" & sql & "$$::jsonb)"
|
|
Call wapi.ClipBoard_SetData(sql)
|
|
|
|
'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
|
|
'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)
|
|
|
|
'Exit Sub
|
|
|
|
'--------------------------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")
|
|
new_sh.Name = "Price Build"
|
|
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
|
|
'create a copy of tbl
|
|
'the default value for cell is error, if any good values are found, they stay
|
|
|
|
j = 0
|
|
For i = 1 To UBound(cms_pl, 1)
|
|
Select Case cms_pl(i, 15)
|
|
Case ""
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
|
|
Case "No UOM Conversion"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
|
|
End If
|
|
Case "Inactive"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 20, 161)
|
|
End If
|
|
Case "No SKU"
|
|
If orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
|
|
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(20, 255, 161)
|
|
End If
|
|
End Select
|
|
'if the current row/column is OK, advance to the next row/column
|
|
j = 0
|
|
Do Until cms_pl(i, 13) <> cms_pl(i + j, 13) Or cms_pl(i, 14) <> cms_pl(i + j, 14)
|
|
j = j + 1
|
|
If i + j >= UBound(cms_pl, 1) Then Exit Do
|
|
Loop
|
|
i = i + j - 1 '-1 becuase the "next i" will increment by 1 again
|
|
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.Columns(3).Interior.Pattern = xlNone
|
|
Selection.Columns(4).Interior.Pattern = xlNone
|
|
Selection.Columns(5).Interior.Pattern = xlNone
|
|
Selection.Columns(6).Interior.Pattern = xlNone
|
|
Selection.Rows(1).Interior.Pattern = xlNone
|
|
|
|
|
|
'----------------------------cleanup-------------------------------------------------------------
|
|
|
|
Set x = Nothing
|
|
|
|
ini.Select
|
|
|
|
|
|
End Sub
|
|
|
|
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
|
|
Dim has_Pricesheet As Boolean
|
|
|
|
has_Pricesheet = False
|
|
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
|
|
has_Pricesheet = True
|
|
End If
|
|
Next cp
|
|
Next ws
|
|
|
|
If Not has_Pricesheet Then
|
|
MsgBox ("no price sheet found")
|
|
Exit Sub
|
|
End If
|
|
|
|
Set orig = Application.Selection
|
|
|
|
Selection.CurrentRegion.Select
|
|
|
|
|
|
trow = orig.row - Selection.row + 1
|
|
tcol = orig.column - Selection.column + 1
|
|
|
|
orig.Select
|
|
|
|
i = 1
|
|
Do Until price_sheet.Cells(i, 1) = ""
|
|
If price_sheet.Cells(i, 15) = trow And price_sheet.Cells(i, 16) = tcol And price_sheet.Cells(i, 14) <> "" Then
|
|
price_sheet.Select
|
|
ActiveSheet.Cells(i, 14).Select
|
|
Exit Sub
|
|
End If
|
|
i = i + 1
|
|
Loop
|
|
|
|
|
|
End Sub
|
|
|
|
|
|
Sub build_price_upload_suff()
|
|
|
|
Dim x As New TheBigOne
|
|
Dim pl() As String
|
|
Dim plv() As Variant
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Dim ul() As String
|
|
Dim pl_code As String
|
|
Dim pl_action As String
|
|
Dim dtl_action As String
|
|
Dim pl_d1 As String
|
|
Dim pl_d2 As String
|
|
Dim pl_d3 As String
|
|
Dim fd As FileDialog
|
|
Dim ulsql As String
|
|
Dim temp() As String
|
|
Dim wapi As New Windows_API
|
|
|
|
|
|
pl = x.SHTp_GetString(Selection)
|
|
ReDim ul(11, UBound(pl, 2))
|
|
|
|
PRICELIST_SHOW:
|
|
|
|
Call pricelist.load_lists
|
|
|
|
pricelist.Show
|
|
|
|
If Not pricelist.proceed Then Exit Sub
|
|
|
|
pl_code = pricelist.cbLIST.value
|
|
pl_d1 = pricelist.tbD1.text
|
|
pl_d2 = pricelist.tbD2.text
|
|
pl_d3 = pricelist.tbD3.text
|
|
pl_action = Mid(pricelist.cbHDR.value, 1, 1)
|
|
dtl_action = Mid(pricelist.cbDTL.value, 1, 1)
|
|
|
|
|
|
If Len(pricelist.cbLIST.value) > 5 Then
|
|
MsgBox ("price code must be 5 or less characters")
|
|
GoTo PRICELIST_SHOW
|
|
End If
|
|
|
|
'--------------remove any lines with errors-------------
|
|
If Not pricelist.cbInactive Then
|
|
Call x.TBLp_FilterSingle(pl, 16, "", True)
|
|
End If
|
|
|
|
'--------------remove empty price lines-----------------
|
|
Call x.TBLp_FilterSingle(pl, 13, "", False)
|
|
|
|
If Not pricelist.cbNonStocked Then
|
|
Call x.TBLp_FilterSingle(pl, 8, "A", True)
|
|
End If
|
|
|
|
'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, PostgreSQL, False)
|
|
'pl = x.TBLp_Transpose(pl)
|
|
'plv = x.TBLp_StringToVar(pl)
|
|
'ulsql = x.json_from_table(plv, "")
|
|
'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
|
|
'Call wapi.ClipBoard_SetData(ulsql)
|
|
'Exit Sub
|
|
|
|
'If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") 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)
|
|
|
|
|
|
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"
|
|
j = 0
|
|
For i = LBound(pl, 2) + 1 To UBound(pl, 2)
|
|
'if there is no [uom, part#, price], don't create a row
|
|
If pl(11, i) <> "" And pl(7, i) <> "" And pl(6, i) <> "" And pl(13, i) <> "" Then
|
|
j = j + 1
|
|
ul(0, j) = "DTL" 'DTL
|
|
ul(1, j) = pl_code 'Price list code
|
|
ul(2, j) = pl(6, i) 'part number
|
|
ul(3, j) = pl(12, i) 'price unit
|
|
ul(4, j) = Format(pl(11, i), "0.00000") 'volume break in price uom
|
|
ul(5, j) = Format(pl(13, i), "0.00000") 'price
|
|
ul(11, j) = dtl_action 'add, update, delete
|
|
End If
|
|
Next i
|
|
|
|
ReDim Preserve ul(11, j)
|
|
|
|
|
|
'--------Open file-------------
|
|
|
|
If Not x.FILEp_CreateCSV(pricelist.tbPATH.text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then
|
|
MsgBox ("error")
|
|
End If
|
|
|
|
'Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv")
|
|
|
|
'---------------------header row---------------------------------
|
|
|
|
|
|
End Sub
|
|
|
|
Sub price_load_pcore()
|
|
|
|
Dim x As New TheBigOne 'function library
|
|
Dim sh As Worksheet 'target worksheet
|
|
Dim big() As String 'all price lists in one array
|
|
Dim load() As String 'individual price list to be loaded
|
|
Dim pcount As Long 'count of price list
|
|
Dim pcol() As Long 'hold the positions of each price list
|
|
ReDim pcol(30) 'size the array starting with 30 and trim later
|
|
Dim dcol() As Integer 'columns to be deleted
|
|
Dim typeflag() As String 'array of column types
|
|
Dim i As Long
|
|
Dim j As Long
|
|
Dim sql As String
|
|
|
|
'-------identify the active sheet and load the contents to an array-----------
|
|
|
|
Set sh = ActiveSheet
|
|
big = x.SHTp_Get(sh.Name, 3, 1, True)
|
|
|
|
'------iterate through the column headers to identify the price lists---------
|
|
|
|
pcount = 0
|
|
For i = 0 To UBound(big, 1)
|
|
If big(i, 0) = "plist" Then
|
|
pcount = pcount + 1
|
|
pcol(pcount) = i
|
|
End If
|
|
Next i
|
|
|
|
'------if no columns are labeled plist then exit------------------------------
|
|
|
|
If pcount = 0 Then Exit Sub
|
|
ReDim Preserve pcol(pcount)
|
|
ReDim typeflag(9)
|
|
|
|
If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
|
|
MsgBox (Err.Description)
|
|
Exit Sub
|
|
End If
|
|
|
|
'------prepare upload for each price list-------------------------------------
|
|
|
|
typeflag(0) = "S"
|
|
typeflag(1) = "S"
|
|
typeflag(2) = "S"
|
|
typeflag(3) = "S"
|
|
typeflag(4) = "S"
|
|
typeflag(5) = "S"
|
|
typeflag(6) = "N"
|
|
typeflag(7) = "N"
|
|
typeflag(8) = "N"
|
|
typeflag(9) = "S"
|
|
|
|
For pcount = 1 To UBound(pcol)
|
|
ReDim load(9, UBound(big, 2))
|
|
'----set headers-----
|
|
load(0, 0) = "stlc"
|
|
load(1, 0) = "coltier"
|
|
load(2, 0) = "branding"
|
|
load(3, 0) = "accs"
|
|
load(4, 0) = "suff"
|
|
load(5, 0) = "pckg"
|
|
load(6, 0) = "pack"
|
|
load(7, 0) = "mp"
|
|
load(8, 0) = "bulk"
|
|
load(9, 0) = "plist"
|
|
'-----populate------------
|
|
For i = 1 To UBound(big, 2)
|
|
load(0, i) = big(0, i)
|
|
load(1, i) = big(1, i)
|
|
load(2, i) = big(2, i)
|
|
load(3, i) = big(3, i)
|
|
load(4, i) = big(4, i)
|
|
load(5, i) = big(5, i)
|
|
load(6, i) = Format(big(pcol(pcount) - 3, i), "####0.00")
|
|
load(7, i) = Format(big(pcol(pcount) - 2, i), "####0.00")
|
|
load(8, i) = Format(big(pcol(pcount) - 1, i), "####0.00")
|
|
load(9, i) = big(pcol(pcount) - 0, i)
|
|
Next i
|
|
'------build insert statement for target price list-----
|
|
sql = "BEGIN;"
|
|
sql = sql & vbCrLf & "DELETE FROM rlarp.pcore WHERE plist = '" & load(9, 1) & "';"
|
|
sql = sql & vbCrLf & "INSERT INTO rlarp.pcore"
|
|
sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "N", "N", "N", "S") & ";"
|
|
sql = sql & vbCrLf & "COMMIT;"
|
|
'------do the insert------------------------------------
|
|
If Not x.ADOp_Exec(0, sql) Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Exit Sub
|
|
End If
|
|
Next pcount
|
|
|
|
Call x.ADOp_CloseCon(0)
|
|
|
|
|
|
End Sub
|
|
|
|
Sub price_issues()
|
|
|
|
Dim x As New TheBigOne
|
|
Dim ilist() As String
|
|
Dim sql As String
|
|
|
|
If ActiveSheet.Name <> "Issues" Then Exit Sub
|
|
|
|
ilist = x.SHTp_Get(ActiveSheet.Name, 1, 1, True)
|
|
sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.issues;" & vbCrLf & "INSERT INTO rlarp.issues" & vbCrLf
|
|
sql = sql & x.SQLp_build_sql_values(ilist, True, True, PostgreSQL, False, "S", "S", "S", "S") & ";"
|
|
sql = sql & vbCrLf & "END;"
|
|
|
|
|
|
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
|
|
MsgBox (x.ADOo_errstring)
|
|
End If
|
|
|
|
Call x.ADOp_CloseCon(0)
|
|
|
|
Set x = Nothing
|
|
|
|
End Sub
|
|
|
|
Sub nursery_parse()
|
|
|
|
Dim tbo As New TheBigOne
|
|
Dim sh As Worksheet
|
|
Dim a As Long 'header row
|
|
Dim i As Long 'last row
|
|
Dim j As Long 'starting column
|
|
Dim c As Long 'customer column
|
|
Dim n As Long 'customer count
|
|
Dim x As Long 'max column
|
|
Dim b As Long 'ext part iterator
|
|
Dim z As Long 'ext all rows iterator
|
|
Dim partcol As Long 'part number column
|
|
Dim p() As Double 'log
|
|
Dim m() As String 'customer name
|
|
Dim ext() As String
|
|
Dim sql As String
|
|
Dim exists As Boolean
|
|
|
|
z = 0
|
|
partcol = 2
|
|
ReDim ext(3, 10000)
|
|
ext(0, 0) = "part"
|
|
ext(1, 0) = "customer"
|
|
ext(2, 0) = "price"
|
|
ext(3, 0) = "region"
|
|
|
|
For Each sh In Application.Worksheets
|
|
If InStr(sh.Name, "Price & Vol") > 0 Then
|
|
ReDim p(30)
|
|
ReDim m(30)
|
|
a = 6
|
|
'----find max row------------------------------------
|
|
i = a + 1
|
|
Do Until sh.Cells(i, 2) = "" Or i = 1000
|
|
i = i + 1
|
|
Loop
|
|
i = i - 1
|
|
'----find starting column----------------------------
|
|
j = 1
|
|
Do Until InStr(sh.Cells(a, j), "Order $") Or j = 1000
|
|
j = j + 1
|
|
Loop
|
|
c = 1
|
|
'----identity price columns numbers------------------
|
|
n = 0
|
|
Do Until sh.Cells(a, c + j) = ""
|
|
If InStr(sh.Cells(a, c + j), "NEW PRICE") > 0 Then
|
|
n = n + 1
|
|
p(n) = c + j
|
|
End If
|
|
c = c + 1
|
|
Loop
|
|
x = c + j
|
|
'----get the customer names--------------------------
|
|
n = 0
|
|
For c = j To x
|
|
If sh.Cells(a - 1, c) <> "" Then
|
|
n = n + 1
|
|
m(n) = sh.Cells(a - 1, c)
|
|
End If
|
|
Next c
|
|
|
|
'---resize arrays------
|
|
ReDim Preserve p(n)
|
|
ReDim Preserve m(n)
|
|
|
|
'---for each customer loop through all the parts
|
|
For n = 1 To UBound(p)
|
|
For b = a + 1 To i
|
|
z = z + 1
|
|
ext(0, z) = sh.Cells(b, partcol)
|
|
ext(1, z) = m(n)
|
|
ext(2, z) = sh.Cells(b, p(n))
|
|
ext(3, z) = sh.Cells(2, 1)
|
|
Next b
|
|
Next n
|
|
Else
|
|
'not a price tab
|
|
End If
|
|
|
|
Next sh
|
|
|
|
ReDim Preserve ext(3, z)
|
|
Call tbo.TBLp_FilterSingle(ext, 2, "0", False)
|
|
Call tbo.TBLp_FilterSingle(ext, 2, "", False)
|
|
|
|
'---------dump consolidated pricing to worksheet------------
|
|
exists = False
|
|
For Each sh In Application.Worksheets
|
|
If sh.Name = "consolidated price list" Then
|
|
sh.Cells.ClearContents
|
|
exists = True
|
|
Exit For
|
|
End If
|
|
Next sh
|
|
|
|
'---------
|
|
If Not exists Then
|
|
Set sh = Application.Worksheets.Add()
|
|
sh.Name = "consolidated price list"
|
|
End If
|
|
|
|
Call tbo.SHTp_Dump(ext, "consolidated price list", 1, 1, False, True)
|
|
ext = tbo.TBLp_Transpose(ext)
|
|
|
|
' sql = tbo.ADOp_BuildInsertSQL(ext, "rlarp.nregional", True, 1, UBound(ext, 2), Array("S", "S", "N", "S"))
|
|
' sql = "truncate table rlarp.nregional;" & vbCrLf & sql & ";"
|
|
' If Not tbo.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
|
|
' MsgBox (tbo.ADOo_errstring)
|
|
' Else
|
|
' MsgBox ("Uploaded")
|
|
' End If
|
|
|
|
|
|
End Sub
|
|
|
|
Sub convert_to_value()
|
|
|
|
Dim c As Object
|
|
|
|
For Each c In Selection.Cells
|
|
If IsNumeric(c.value) Then c.value = CDbl(c.value)
|
|
Next c
|
|
|
|
|
|
End Sub
|
|
|
|
Sub pricegroup_upload()
|
|
|
|
Dim sql As String
|
|
Selection.CurrentRegion.Select
|
|
|
|
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A")
|
|
sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "COMMIT;"
|
|
|
|
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Exit Sub
|
|
Else
|
|
'MsgBox ("Upload Complete")
|
|
End If
|
|
|
|
Call x.ADOp_CloseCon(0)
|
|
|
|
sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A")
|
|
sql = "BEGIN" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "END"
|
|
|
|
If Not x.ADOp_Exec(0, sql, 1, True, ADOinterface.SqlServer, "usmidsql01", True) Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Else
|
|
'MsgBox ("Upload Complete")
|
|
End If
|
|
|
|
Call x.ADOp_CloseCon(0)
|
|
|
|
Set x = Nothing
|
|
|
|
Call pricegroup_upload_db2
|
|
|
|
MsgBox ("Upload Complete")
|
|
|
|
End Sub
|
|
|
|
Sub pricegroup_upload_db2()
|
|
|
|
Dim sql As String
|
|
Selection.CurrentRegion.Select
|
|
Dim ulv() As Variant
|
|
Dim ul() As String
|
|
Dim i As Long
|
|
Dim inc As Long
|
|
|
|
ulv = Selection
|
|
ul = x.TBLp_VarToString(ulv)
|
|
ul = x.TBLp_Transpose(ul)
|
|
|
|
'sql = x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, False)
|
|
'sql = "BEGIN" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "END"
|
|
|
|
'Dim w As New Windows_API
|
|
'Call w.ClipBoard_SetData(sql)
|
|
|
|
If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@048") Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Exit Sub
|
|
End If
|
|
|
|
If Not x.ADOp_Exec(0, "DELETE FROM rlarp.price_map") Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Exit Sub
|
|
End If
|
|
|
|
|
|
'------------incremental upload----------------------
|
|
i = 2
|
|
inc = 250
|
|
Do While i <= UBound(ul, 2)
|
|
'sql = x.ADOp_BuildInsertSQL(ul, "rlarp.price_map", True, i, WorksheetFunction.Min(i + inc, UBound(ul, 2)), Array("S", "S", "S", "S", "S", "S", "S", "N", "S", "S"))
|
|
sql = x.SQLp_build_sql_values_ranged(ul, True, True, Db2, False, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A")
|
|
sql = "INSERT INTO rlarp.price_map " & vbCrLf & sql
|
|
If Not x.ADOp_Exec(0, sql) Then
|
|
MsgBox (x.ADOo_errstring)
|
|
Call x.ADOp_CloseCon(0)
|
|
Exit Sub
|
|
End If
|
|
i = i + inc + 1
|
|
If i > UBound(ul, 2) Then Exit Do
|
|
If i + inc > UBound(ul, 2) Then inc = UBound(ul, 2) - i
|
|
Loop
|
|
|
|
'MsgBox ("Upload Complete")
|
|
|
|
Call x.ADOp_CloseCon(0)
|
|
|
|
Set x = Nothing
|
|
|
|
|
|
End Sub
|