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, True)) 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, 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, 1, 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, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;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) = big(6, i) 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.plcore WHERE plist = '" & load(9, 1) & "';" sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" sql = sql & vbCrLf & x.SQLp_build_sql_values(big, True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "S", "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_load_pcore_one() 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, 1, 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) = "listcode" 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, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;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) = big(6, i) ' 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.plcore WHERE listcode= '" & big(9, 1) & "';" sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" sql = sql & vbCrLf & x.SQLp_build_sql_values(big, True, True, PostgreSQL, False, True, "S", "S", "S", "S", "S", "S", "S", "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 = "MERGE INTO RLARP.ISSUES i USING (" & vbCrLf sql = sql & x.SQLp_build_sql_values(ilist, True, True, Db2, False, True, "N", "N", "S", "D") sql = sql & vbCrLf & ") x ON" & vbCrLf & " x.ordern = i.ordern" & vbCrLf & " AND x.linen = i.linen" & vbCrLf & "WHEN MATCHED THEN UPDATE SET" & vbCrLf & " i.issue = x.issue" & vbCrLf & " ,i.odate = x.odate" & vbCrLf & "WHEN NOT MATCHED THEN INSERT VALUES (" & vbCrLf & " x.ordern , x.linen, x.issue, x.odate" & vbCrLf & ")" If Not x.ADOp_Exec(0, sql, 1, True, ISeries, "s7830956", False, "ptrowbridg", "qqqx53@048") 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, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J") 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, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;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, True, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "J") 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, True, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "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 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 Sub MergeSameCellsInColumn() Dim ws As Worksheet Dim rng As Range Dim cell As Range Dim firstRow As Long Dim lastRow As Long Dim colNum As Long Dim startMerge As Range Dim endMerge As Range ' Set the worksheet where you want to perform the operation Set ws = ActiveSheet ' Define the column number to check for duplicates (A = 1, B = 2, etc.) colNum = Selection.column ' Define the range of rows to work on (you can customize this as needed) firstRow = Selection.row lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row ' Set the range of cells in the specified column to process Set rng = ws.Range(ws.Cells(firstRow, colNum), ws.Cells(lastRow, colNum)) Application.DisplayAlerts = False Application.ScreenUpdating = False Set startMerge = Nothing For Each cell In rng If startMerge Is Nothing Then Set startMerge = cell ElseIf cell.value <> startMerge.value Then Set endMerge = cell.Offset(-1, 0) If startMerge.row <> endMerge.row Then ws.Range(startMerge, endMerge).merge End If Set startMerge = cell End If Next cell If cell Is Nothing Then Set cell = ws.Cells(ws.Rows.Count, colNum).End(xlUp) ' Check for the last group of same values If startMerge.row <> cell.row Then ws.Range(startMerge, cell).merge End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Sub merge_block(column_num As Long, row_num As Long) Dim ws As Worksheet Dim rng As Range Dim cell As Range Dim firstRow As Long Dim lastRow As Long Dim colNum As Long Dim startMerge As Range Dim endMerge As Range ' Set the worksheet where you want to perform the operation Set ws = ActiveSheet ' Define the column number to check for duplicates (A = 1, B = 2, etc.) colNum = column_num ' Define the range of rows to work on (you can customize this as needed) firstRow = row_num lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row ' Set the range of cells in the specified column to process Set rng = ws.Range(ws.Cells(firstRow, colNum), ws.Cells(lastRow, colNum)) Application.DisplayAlerts = False Application.ScreenUpdating = False Set startMerge = Nothing For Each cell In rng If startMerge Is Nothing Then Set startMerge = cell ElseIf cell.value <> startMerge.value Then Set endMerge = cell.Offset(-1, 0) If startMerge.row <> endMerge.row Then ws.Range(startMerge, endMerge).merge End If Set startMerge = cell End If Next cell If cell Is Nothing Then Set cell = ws.Cells(ws.Rows.Count, colNum).End(xlUp) ' Check for the last group of same values If startMerge.row <> cell.row Then ws.Range(startMerge, cell).merge End If Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Sub merge_first_2_col_row3() Call FL.merge_block(1, 3) Call FL.merge_block(2, 3) With ActiveSheet.Range("A3:B10000").Borders .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End Sub Sub unmerge_first2() ActiveSheet.Range("A:B").MergeCells = False ActiveSheet.Range("A:B").Borders(xlDiagonalDown).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlDiagonalUp).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlEdgeLeft).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlEdgeTop).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlEdgeBottom).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlEdgeRight).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlInsideVertical).LineStyle = xlNone ActiveSheet.Range("A:B").Borders(xlInsideHorizontal).LineStyle = xlNone End Sub Sub load_ffterr() Dim x As New TheBigOne Dim sql As String login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN; DELETE FROM IMPORT.FFTERR; INSERT INTO import.FFTERR" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("FFTERR", 1, 1, True), False, True, PostgreSQL, False, True, "S", "S", "S", "S", "J") & ";" sql = sql & vbLf & "DELETE FROM rlarp.ffterr; INSERT INTO rlarp.ffterr SELECT * FROM import.ffterr; END;" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If MsgBox ("Complete") End Sub Sub load_ffcret() Dim x As New TheBigOne Dim sql As String login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU, login.tbP) Then Exit Sub End If sql = "BEGIN DELETE FROM RLARP.FFCRET; INSERT INTO RLARP.FFCRET" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("FFCRET", 1, 1, True), False, True, Db2, False, True, "S", "S", "S", "S", "N") & ";" sql = sql & vbLf & "END" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If MsgBox ("Complete") End Sub Sub load_csrca() Dim x As New TheBigOne Dim sql As String login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN; DELETE FROM IMPORT.CSRCA; INSERT INTO import.CSRCA" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("CSRCA", 1, 1, True), False, True, PostgreSQL, False, True, "S", "S", "S", "S", "J") & ";" sql = sql & vbLf & "DELETE FROM rlarp.csrca; INSERT INTO rlarp.csrca SELECT * FROM import.csrca; END;" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If MsgBox ("Complete") End Sub Sub load_prm() Dim x As New TheBigOne Dim sql As String login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN; DELETE FROM IMPORT.PRM; INSERT INTO import.prm" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("prm", 1, 1, True), False, True, PostgreSQL, False, True, "A", "A") & ";" sql = sql & vbLf & "DELETE FROM rlarp.prm; INSERT INTO rlarp.prm SELECT * FROM import.prm; END;" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If MsgBox ("Complete") End Sub Sub load_qrh() Dim x As New TheBigOne Dim sql As String login.Caption = "Postgres Creds" login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If login.Caption = "iSeries Creds" login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(1, ISeries, "S7830956", False, login.tbU, login.tbP) Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN; DELETE FROM IMPORT.QRH; INSERT INTO import.qrh" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("qrh", 1, 1, True), False, True, PostgreSQL, False, True, "A", "A") & ";" sql = sql & vbLf & "DELETE FROM rlarp.qrh; INSERT INTO rlarp.qrh SELECT * FROM import.qrh; END;" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN DELETE FROM RLARP.QRH; INSERT INTO RLARP.QRH" & vbCrLf sql = sql & x.SQLp_build_sql_values(x.SHTp_Get("qrh", 1, 1, True), True, True, Db2, False, True, "A", "A") & ";" sql = sql & vbCrLf & " END" If Not x.ADOp_Exec(1, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If End Sub Sub load_index() Dim x As New TheBigOne Dim sql As String login.Caption = "Postgres Creds" login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidsap01", False, login.tbU, login.tbP, "database=ubm") Then MsgBox (x.ADOo_errstring) Exit Sub End If sql = "BEGIN; DELETE FROM IMPORT.COSTINDEX; INSERT INTO import.costindex" sql = sql & vbLf & x.SQLp_build_sql_values(x.SHTp_Get("INDEX", 1, 1, True), False, True, PostgreSQL, False, True, "J", "DR", "N") & ";" sql = sql & vbLf & "DELETE FROM rlarp.costindex; INSERT INTO rlarp.costindex SELECT * FROM import.costindex; END;" If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Exit Sub End If End Sub