VBA/FL.bas

1662 lines
47 KiB
QBasic
Raw Normal View History

2020-01-13 17:23:39 -05:00
Attribute VB_Name = "FL"
2020-09-15 13:02:06 -04:00
2020-01-13 17:23:39 -05:00
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
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
Dim idest As Range
2020-01-13 17:23:39 -05:00
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)
2020-01-13 17:23:39 -05:00
If idest Is Nothing Then
2020-01-13 17:23:39 -05:00
Exit Sub
End If
Call x.SHTp_Dump(r1, Excel.ActiveSheet.Name, idest.row, idest.column, False, True)
2020-01-13 17:23:39 -05:00
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
2021-06-16 09:03:23 -04:00
Dim p As FileDialog
2020-01-13 17:23:39 -05:00
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-------------
2021-06-16 09:03:23 -04:00
Set p = Application.FileDialog(msoFileDialogOpen)
p.Show
2020-01-13 17:23:39 -05:00
'--------Extract text----------
2021-06-16 09:03:23 -04:00
f = x.FILEp_GetTXT(p.SelectedItems(1), 2000)
2020-01-13 17:23:39 -05:00
'--------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"
2021-06-16 09:03:23 -04:00
If Not x.FILEp_CreateCSV(Mid(p.SelectedItems(1), 1, Len(p.SelectedItems(1)) - 4) & "col.csv", col) Then
2020-01-13 17:23:39 -05:00
MsgBox ("error")
End If
2021-06-16 09:03:23 -04:00
If Not x.FILEp_CreateCSV(Mid(p.SelectedItems(1), 1, Len(p.SelectedItems(1)) - 4) & "bal.csv", bal) Then
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
Sub PastValues()
Attribute PastValues.VB_ProcData.VB_Invoke_Func = "V\n14"
2020-09-15 13:02:06 -04:00
2020-01-13 17:23:39 -05:00
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()
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
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
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-09-15 13:02:06 -04:00
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
2020-01-13 17:23:39 -05:00
Sub Write_selection()
2021-06-16 09:03:23 -04:00
Dim p As FileDialog
2020-01-13 17:23:39 -05:00
'--------Open file-------------
2021-06-16 09:03:23 -04:00
Set p = Application.FileDialog(msoFileDialogSaveAs)
p.Show
2020-01-13 17:23:39 -05:00
2021-06-16 09:03:23 -04:00
Call x.FILEp_CreateTXT(p.SelectedItems(1), x.SHTp_Get(ActiveSheet.Name, Selection.row, Selection.column, False))
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
Dim unps() As String
Dim sql As String
Dim error As String
Dim orig As Range
Dim ini As Range
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
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"
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
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"
2020-01-13 17:23:39 -05:00
If Not x.TBLp_TestNumeric(unp, 7) Then
2020-01-13 17:23:39 -05:00
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
2022-02-09 10:56:13 -05:00
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
2020-11-06 14:48:49 -05:00
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-------------------------------------------------
2020-11-06 14:48:49 -05:00
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)
2020-09-15 13:02:06 -04:00
'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
'Exit Sub
login.Show
If Not login.proceed Then Exit Sub
2022-02-09 10:56:13 -05:00
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")
2020-09-15 13:02:06 -04:00
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
2020-09-15 13:02:06 -04:00
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
2020-11-06 14:48:49 -05:00
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
2020-11-06 14:48:49 -05:00
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)
2020-11-06 14:48:49 -05:00
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
2020-09-15 13:02:06 -04:00
'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)
2020-09-15 13:02:06 -04:00
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
2020-09-15 13:02:06 -04:00
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
2020-09-15 13:02:06 -04:00
'----------------------------cleanup-------------------------------------------------------------
Set x = Nothing
2020-11-06 14:48:49 -05:00
ini.Select
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
Dim has_Pricesheet As Boolean
2020-01-13 17:23:39 -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
has_Pricesheet = True
2020-01-13 17:23:39 -05:00
End If
Next cp
Next ws
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
orig.Select
2020-01-13 17:23:39 -05:00
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
2020-01-13 17:23:39 -05:00
price_sheet.Select
ActiveSheet.Cells(i, 14).Select
2020-01-13 17:23:39 -05:00
Exit Sub
End If
i = i + 1
Loop
End Sub
2020-09-15 13:02:06 -04:00
Sub build_price_upload_suff()
2020-09-15 13:02:06 -04:00
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
2022-02-09 10:56:13 -05:00
pl_d1 = pricelist.tbD1.text
pl_d2 = pricelist.tbD2.text
pl_d3 = pricelist.tbD3.text
2020-09-15 13:02:06 -04:00
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-------------
2020-09-15 13:02:06 -04:00
If Not pricelist.cbInactive Then
Call x.TBLp_FilterSingle(pl, 16, "", True)
2020-09-15 13:02:06 -04:00
End If
'--------------remove empty price lines-----------------
Call x.TBLp_FilterSingle(pl, 13, "", False)
2020-09-15 13:02:06 -04:00
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-------------
2022-02-09 10:56:13 -05:00
If Not x.FILEp_CreateCSV(pricelist.tbPATH.text & "\" & Replace(pl_code, ".", "_") & ".csv", ul) Then
2020-09-15 13:02:06 -04:00
MsgBox ("error")
End If
'Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & Replace(pl_code, ".", "_") & ".csv")
'---------------------header row---------------------------------
End Sub
2021-03-15 15:41:44 -04:00
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------------
2021-03-15 15:41:44 -04:00
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------------------------------------
2021-03-15 15:41:44 -04:00
If Not x.ADOp_Exec(0, sql) Then
MsgBox (x.ADOo_errstring)
Exit Sub
End If
Next pcount
Call x.ADOp_CloseCon(0)
2021-03-15 15:41:44 -04:00
End Sub
2021-06-16 09:03:23 -04:00
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
2021-08-13 10:34:20 -04:00
Dim exists As Boolean
2021-06-16 09:03:23 -04:00
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
2022-02-09 10:56:13 -05:00
If InStr(sh.Name, "Price & Vol") > 0 Then
2021-06-16 09:03:23 -04:00
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
2021-08-13 10:34:20 -04:00
Do Until InStr(sh.Cells(a, j), "Order $") Or j = 1000
2021-06-16 09:03:23 -04:00
j = j + 1
Loop
c = 1
'----identity price columns numbers------------------
n = 0
Do Until sh.Cells(a, c + j) = ""
2021-08-13 10:34:20 -04:00
If InStr(sh.Cells(a, c + j), "NEW PRICE") > 0 Then
2021-06-16 09:03:23 -04:00
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)
2021-08-13 10:34:20 -04:00
'---------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)
2022-02-09 10:56:13 -05:00
' 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
2021-06-16 09:03:23 -04:00
2021-08-13 10:34:20 -04:00
End Sub
Sub convert_to_value()
2021-08-13 11:01:12 -04:00
Dim c As Object
2021-08-13 10:34:20 -04:00
For Each c In Selection.Cells
If IsNumeric(c.value) Then c.value = CDbl(c.value)
Next c
2021-06-16 09:03:23 -04:00
End Sub
2021-08-13 11:01:12 -04:00
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, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "J")
2022-02-09 10:56:13 -05:00
sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "COMMIT;"
2021-08-13 11:01:12 -04:00
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
MsgBox (x.ADOo_errstring)
2022-02-09 10:56:13 -05:00
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, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "A")
2022-02-09 10:56:13 -05:00
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)
2021-08-13 11:01:12 -04:00
Else
2022-04-07 12:39:00 -04:00
'MsgBox ("Upload Complete")
2021-08-13 11:01:12 -04:00
End If
Call x.ADOp_CloseCon(0)
2022-02-09 10:56:13 -05:00
Set x = Nothing
Call pricegroup_upload_db2
2022-04-07 12:39:00 -04:00
MsgBox ("Upload Complete")
2022-02-09 10:56:13 -05:00
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, True, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "N", "S", "S", "S", "A", "A", "A")
2022-02-09 10:56:13 -05:00
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
2022-04-07 12:39:00 -04:00
'MsgBox ("Upload Complete")
2022-02-09 10:56:13 -05:00
Call x.ADOp_CloseCon(0)
Set x = Nothing
2021-08-13 11:01:12 -04:00
End Sub
2022-05-12 10:07:54 -04:00
Sub clear_page_breaks()
Dim b As Workbook
Dim s As Worksheet
For Each b In Workbooks
For Each s In b.Worksheets
If s.DisplayPageBreaks Then s.DisplayPageBreaks = False
Next s
Next b
End Sub