Attribute VB_Name = "FL" Option Explicit Public price_sheet As Worksheet Public x As New TheBigOne Sub Determine_Active_Range() Dim r As Range Dim s As String Dim cell As Range Set r = Selection MsgBox (r.address) For Each cell In r.Cells s = s & cell.value Next cell MsgBox (s) End Sub Sub Cross_Join_Selection() Dim x As New TheBigOne Dim r As Range Dim ar As Range Dim r1() As String Dim r2() As String Dim d() As String Dim i As Integer Dim dest As String Set r = Selection i = 1 For Each ar In r.Areas If i = 1 Then r1 = x.SHTp_Get(Excel.ActiveSheet.Name, ar.row, ar.column, False) Else r2 = x.SHTp_Get(Excel.ActiveSheet.Name, ar.row, ar.column, False) r1 = x.TBLp_CrossJoin(r1, r2, True) End If i = i + 1 Next ar dest = InputBox("Input row & column numbers like ""3,17""") If dest = "" Then Exit Sub Else d = Split(dest, ",") End If Call x.SHTp_Dump(r1, Excel.ActiveSheet.Name, CLng(d(0)), CLng(d(1)), False, True) End Sub Sub BackupPersonal() Application.DisplayAlerts = False With Workbooks("Personal.xlsb") .SaveCopyAs Workbooks("Personal.xlsb").Sheets("CONST").Cells(1, 2) .Save End With Application.DisplayAlerts = True End Sub Sub ExtractPNC_CSV() Dim x As New TheBigOne Dim f() As String Dim col() As String Dim coli As Long Dim bal() As String Dim bali As Long Dim sched_loan As String Dim P As FileDialog Dim i As Long Dim j As Long Dim m As Long Dim k As Long Dim row() As String Dim commit As Integer Dim oblig As Integer Dim sched As Integer Dim loan As Integer Dim wb As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet '--------Open file------------- Set P = Application.FileDialog(msoFileDialogOpen) P.Show '--------Extract text---------- f = x.FILEp_GetTXT(P.SelectedItems(1), 2000) '--------resize arrays--------- ReDim col(11, UBound(f, 2)) ReDim bal(8, UBound(f, 2)) coli = 1 bali = 1 j = 1 m = 1 '--------main interation------- For i = 0 To UBound(f, 2) sched = InStr(f(0, i), "Schedule") loan = InStr(f(0, i), "Loan") If sched <> 0 Then row = x.TXTp_ParseCSVrow(f, i + 2, 0) col(0, 0) = "Schedule#" For k = 0 To 10 col(k + 1, 0) = row(k) Next k sched_loan = x.TXTp_ParseCSVrow(f, i + 1, 0)(0) i = i + 3 commit = 0 oblig = 0 Do Until commit <> 0 Or oblig <> 0 row = x.TXTp_ParseCSVrow(f, i, 0) col(0, j) = sched_loan For k = 0 To 10 col(k + 1, j) = row(k) Next k j = j + 1 i = i + 1 commit = InStr(f(0, i), "Commitment") oblig = InStr(f(0, i), "Oblig") '---or end of file----- Loop sched = 0 ElseIf loan <> 0 Then row = x.TXTp_ParseCSVrow(f, i + 2, 0) bal(0, 0) = "Loan#" For k = 0 To 7 bal(k + 1, 0) = row(k) Next k sched_loan = x.TXTp_ParseCSVrow(f, i + 1, 0)(0) i = i + 3 commit = 0 oblig = 0 Do Until commit <> 0 Or oblig <> 0 row = x.TXTp_ParseCSVrow(f, i, 0) bal(0, m) = sched_loan For k = 0 To 7 bal(k + 1, m) = row(k) Next k m = m + 1 i = i + 1 If i > UBound(f, 2) Then Exit Do If f(0, i) = "" Then Exit Do commit = InStr(f(0, i), "Commitment") oblig = InStr(f(0, i), "Oblig") '---or end of file----- Loop sched = 0 loan = 0 End If Next i ReDim Preserve col(11, j - 2) ReDim Preserve bal(8, m - 1) ' Set wb = Workbooks.Add ' wb.Sheets.Add ' Set sh1 = wb.Sheets("Sheet1") ' Set sh2 = wb.Sheets("Sheet2") ' sh1.Name = "Collateral" ' sh2.Name = "Balance" If Not x.FILEp_CreateCSV(Mid(P.SelectedItems(1), 1, Len(P.SelectedItems(1)) - 4) & "col.csv", col) Then MsgBox ("error") End If If Not x.FILEp_CreateCSV(Mid(P.SelectedItems(1), 1, Len(P.SelectedItems(1)) - 4) & "bal.csv", bal) Then MsgBox ("error") End If ' Call x.SHTp_Dump(col, sh1.Name, 1, 1, True, True, 1, 4, 5, 6, 7, 8, 9, 10, 11) ' Call x.SHTp_Dump(bal, sh2.Name, 1, 1, True, True, 1, 2, 5, 6, 7, 8) ' ' sh1.range("A1").CurrentRegion.Columns.AutoFit ' sh2.range("A2").CurrentRegion.Columns.AutoFit ' ' If Not x.FILEp_CreateCSV("C:\users\ptrowbridge\downloads\col.csv", col) Then ' MsgBox ("error") ' End If End Sub Sub GrabBorrowHist() Dim sh As Worksheet Dim x As New TheBigOne Dim i As Long Dim b() As String Set sh = Application.ActiveSheet b = x.SHTp_Get(sh.Name, 3, 1, True) Call x.TBLp_FilterSingle(b, 14, "", False) Call x.TBLp_DeleteCols(b, x.ARRAYp_MakeInteger(6, 7, 8, 9, 10, 11, 12, 13)) Call x.TBLp_AddEmptyCol(b) Call x.TBLp_AddEmptyCol(b) For i = 1 To UBound(b, 2) b(9, i) = ActiveSheet.Name b(10, i) = ActiveWorkbook.Name Next i b(9, 0) = "Tab" b(10, 0) = "File" Application.Workbooks("PERSONAL.XLSB").Activate Set sh = Application.Workbooks("PERSONAL.XLSB").Sheets("BORROW") i = 1 Do Until sh.Cells(i, 1) = "" i = i + 1 Loop Call x.SHTp_Dump(b, "BORROW", i, 1, False, True) End Sub Function fn_coln_colchar(colnum As Long) As String fn_coln_colchar = colnum / 26 End Function Sub add_quote_front() Dim r As Range Set r = Selection Dim c As Object For Each c In r.Cells If c.value <> "" Then c.value = "'" & c.value Next c End Sub Function json_from_list(keys As Range, values As Range) As String Dim json As String Dim i As Integer Dim first_comma As Boolean Dim needs_braces As Integer Dim needs_comma As Boolean needs_comma = False needs_braces = 0 For i = 1 To keys.Cells.Count If values.Cells(i).value <> "" Then needs_braces = needs_braces + 1 If needs_comma Then json = json & "," needs_comma = True If IsNumeric(values.Cells(i).value) Then json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & values.Cells(i).value Else json = json & Chr(34) & keys.Cells(i).value & Chr(34) & ":" & Chr(34) & values.Cells(i).value & Chr(34) End If End If Next i If needs_braces > 0 Then json = "{" & json & "}" json_from_list = json End Function Function json_nest(key As String, json As String) As String json_nest = "{""" & key & """:" & json & "}" End Function Function json_concat(list As Range) As String Dim json As String Dim i As Integer i = 0 For Each cell In list If cell.value <> "" Then i = i + 1 If i = 1 Then json = cell.value Else json = json & "," & cell.value End If End If Next cell If i > 1 Then json = "[" & json & "]" json_concat = json End Function Sub json_from_table_pretty() Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant Selection.CurrentRegion.Select tbl = Selection Dim ajson As String Dim json As String Dim r As Integer Dim c As Integer Dim needs_comma As Boolean Dim needs_braces As Integer needs_comma = False needs_braces = 0 ajson = "" For r = 2 To UBound(tbl, 1) For c = 1 To UBound(tbl, 2) If tbl(r, c) <> "" Then needs_braces = needs_braces + 1 If needs_comma Then json = json & "," & vbCrLf needs_comma = True If IsNumeric(tbl(r, c)) Then json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & tbl(r, c) Else json = json & Chr(34) & tbl(1, c) & Chr(34) & ":" & Chr(34) & tbl(r, c) & Chr(34) End If End If Next c If needs_braces > 0 Then json = "{" & vbCrLf & json & vbCrLf & "}" needs_comma = False needs_braces = 0 If r > 2 Then ajson = ajson & vbCrLf & "," & vbCrLf & json Else ajson = json End If json = "" Next r If r > 2 Then ajson = "[" & ajson & "]" Call wapi.ClipBoard_SetData(ajson) End Sub Sub json_from_table() Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant Selection.CurrentRegion.Select tbl = Selection Call wapi.ClipBoard_SetData(x.json_from_table(tbl, "y", False)) End Sub Sub PastValues() Attribute PastValues.VB_ProcData.VB_Invoke_Func = "V\n14" On Error GoTo errh Call Selection.PasteSpecial(xlPasteValues, xlNone, False, False) errh: End Sub Sub CollapsePvtItem() Attribute CollapsePvtItem.VB_ProcData.VB_Invoke_Func = "Z\n14" On Error GoTo show_det ActiveCell.PivotItem.DrilledDown = False On Error GoTo drill_down ActiveCell.PivotItem.ShowDetail = False show_det: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotItem.ShowDetail = False Err.Number = 0 End If drill_down: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotItem.DrilledDown = False End If errh: End Sub Sub ExpandPvtItem() Attribute ExpandPvtItem.VB_ProcData.VB_Invoke_Func = "X\n14" On Error GoTo show_det ActiveCell.PivotItem.DrilledDown = True On Error GoTo drill_down ActiveCell.PivotItem.ShowDetail = True show_det: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotItem.ShowDetail = True Err.Number = 0 End If drill_down: On Error GoTo errh If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotItem.DrilledDown = True End If errh: End Sub Sub CollapsePvtFld() Attribute CollapsePvtFld.VB_ProcData.VB_Invoke_Func = "A\n14" On Error GoTo show_det ActiveCell.PivotField.DrilledDown = False On Error GoTo drill_down ActiveCell.PivotField.ShowDetail = False show_det: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotField.ShowDetail = False Err.Number = 0 End If drill_down: On Error GoTo errh If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotField.DrilledDown = False End If errh: End Sub Sub ExpandPvtFld() Attribute ExpandPvtFld.VB_ProcData.VB_Invoke_Func = "S\n14" On Error GoTo show_det ActiveCell.PivotField.DrilledDown = True On Error GoTo drill_down ActiveCell.PivotField.ShowDetail = True show_det: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotField.ShowDetail = True Err.Number = 0 End If drill_down: If Err.Number <> 0 Then On Error GoTo errh ActiveCell.PivotField.DrilledDown = True End If errh: End Sub Sub ColorMatrixExtract() Dim s() As String Dim t() As String Dim i As Long Dim j As Long Dim k As Long Dim m As Long Dim sh As Worksheet Dim found As Boolean ReDim s(1, 10000) For Each sh In Sheets If sh.Name = "Color Matrix" Then found = True Next sh If Not found Then Exit Sub Set sh = Sheets("Color Matrix") If sh.Cells(5, 1) <> "BASE WHITE" Then Exit Sub m = 1 i = 1 s(0, 0) = "COLOR ID" s(1, 0) = "DESCRIPTION" Do If sh.Cells(6, i) = "COLOR ID" Then j = 1 Do Until sh.Cells(6, i + j) = "DESCRIPTION" j = j + 1 Loop k = 7 Do Until sh.Cells(k, i) = "" s(0, m) = sh.Cells(k, i) s(1, m) = sh.Cells(k, i + j) k = k + 1 m = m + 1 Loop End If i = i + 1 If i = 500 Then Exit Do Loop ReDim Preserve s(1, m - 1) Call x.SHTp_Dump(s, "Extract", 1, 1, True, True) End Sub Sub SetPivotShortcutKeys() Call Application.MacroOptions("PERSONAL.xlsb!CollapsePvtFld", "", , , , "A") Call Application.MacroOptions("PERSONAL.xlsb!CollapsePvtItem", "", , , , "Z") Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtFld", "", , , , "S") Call Application.MacroOptions("PERSONAL.xlsb!ExpandPvtItem", "", , , , "X") End Sub Sub LoadChan() 'if not x.ADOp_OpenCon(0, End Sub Sub markdown_from_table() Dim x As New TheBigOne Dim wapi As New Windows_API Dim tbl() As Variant Selection.CurrentRegion.Select tbl = Selection Call wapi.ClipBoard_SetData(x.markdown_from_table(tbl)) End Sub Sub json_multirange() Dim wapi As New Windows_API Dim x As New TheBigOne Call wapi.ClipBoard_SetData(x.json_multirange(Selection)) End Sub Sub markdown_whole_sheet() Dim x As New TheBigOne Dim wapi As New Windows_API Call wapi.ClipBoard_SetData(x.markdown_whole_sheet(ActiveSheet)) End Sub Sub sql_from_range() 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)) 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 Write_selection() Dim P As FileDialog '--------Open file------------- Set P = Application.FileDialog(msoFileDialogSaveAs) P.Show Call x.FILEp_CreateTXT(P.SelectedItems(1), x.SHTp_Get(ActiveSheet.Name, Selection.row, Selection.column, False)) End Sub Sub dump_markdown() Dim path As String Dim s As Worksheet Dim x As New TheBigOne Dim wapi As New Windows_API path = ActiveWorkbook.path & "\" & Mid(ActiveWorkbook.Name, 1, InStr(1, ActiveWorkbook.Name, ".xl")) & "md" For Each s In ActiveWorkbook.Worksheets Call wapi.ClipBoard_SetData(x.markdown_whole_sheet(s)) Next s End Sub Sub test() Dim c As New WindCrypt c.Password = "hi" c.InBuffer = "test" Call c.Validate End Sub Sub split_forecast_data() Application.EnableCancelKey = xlDisabled Dim wb As Workbook Dim ws As Worksheet Dim d() As String Dim u() As String Dim f() As String Dim i As Long d = x.SHTp_Get("Data", 1, 1, True) u = d Call x.TBLp_Aggregate(u, False, True, True, Array(1), Array("S"), Array(5, 6, 7, 8)) For i = 1 To UBound(u, 2) Call Sheets("TEMPLATE").Copy(Sheets(i)) Set ws = Sheets(i) ws.Name = Left(RTrim(u(0, i)), 20) f = d Call x.TBLp_FilterSingle(f, 1, u(0, i), True) Call x.SHTp_Dump(f, ws.Name, 3, 12, False, True, 16, 17, 18, 19) Next i End Sub Function range_empty(ByRef r As Range) As Boolean Dim c As Range range_empty = True For Each c In r.Cells If Not IsEmpty(c.value) Then range_empty = False Exit Function End If Next c End Function Function build_monthly(ByRef part As String, billto_group As String, month As String, vol As Double, amt As Double) As String Dim j As Object Set j("part") = part Set j("billto_group") = billto_group Set j("month") = month Set j("part") = vol Set j("part") = amt build_monthly = JsonConverter.ConvertToJson(j) End Function Sub extract_price_matrix() '------------------------------------setup------------------------------------------------- Dim wapi As New Windows_API Dim x As New TheBigOne Dim tbl() As Variant Dim unp() As String Dim unps() As String Dim sql As String Dim error As String Dim orig As Range Dim cms_pl() As String Dim pw As String Dim new_sh As Worksheet Dim ws As Worksheet Dim cp As CustomProperty '------------------------------------selection------------------------------------------------- Set orig = Application.Selection Selection.CurrentRegion.Select Set orig = Application.Selection '--------------------------------test if valid price matrix------------------------------ If Selection.Cells.Count = 1 Then MsgBox ("selection is not a table") orig.Select Exit Sub End If tbl = Selection If UBound(tbl, 1) < 4 Then error = "selection is not a valid price matrix" If UBound(tbl, 2) < 2 Then error = "selection is not a valid price matrix" If Not error = "" Then MsgBox (error) Exit Sub End If '-----------------------------unpivot price matrix into new array----------------------------- Dim i As Long Dim j As Long Dim k As Long k = 0 ReDim unp(7, (UBound(tbl, 2) - 1) * (UBound(tbl, 1) - 3)) For i = 4 To UBound(tbl, 1) For j = 2 To UBound(tbl, 2) k = k + 1 'part unp(0, k) = tbl(i, 1) 'copy headers down the left unp(1, k) = tbl(1, j) 'size code (row one, column j) unp(2, k) = tbl(2, j) 'volue break uom (row 2, column j) unp(3, k) = Format(tbl(3, j), "#.00") 'volue break qty (row 3, column j) unp(4, k) = "M" 'pricing unit of measuer unp(5, k) = Format(tbl(i, j), "#.00") 'price (row i, column j) unp(6, k) = i unp(7, k) = j Next j Next i unp(0, 0) = "mold" unp(1, 0) = "sizc" unp(2, 0) = "vbuom" unp(3, 0) = "vbqty" unp(4, 0) = "puom" unp(5, 0) = "price" unp(6, 0) = "orig_row" unp(7, 0) = "orig_col" If Not x.TBLp_TestNumeric(unp, 3) Then MsgBox ("volume break quantity is text") Exit Sub End If If Not x.TBLp_TestNumeric(unp, 5) Then MsgBox ("price is text") Exit Sub End If '-------------------------prepare sql to upload--------------------------------------------------------------- sql = x.SQLp_build_sql_values(unp, False, True, Db2) sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA" Call wapi.ClipBoard_SetData(sql) If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub login.Show If Not login.proceed Then Exit Sub If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring) Exit Sub End If If Not x.ADOp_Exec(0, sql) Then MsgBox (x.ADOo_errstring) Call x.ADOp_CloseCon(0) Exit Sub End If '-------------------call price build procedure-------------------------------------------------------- cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True) Call x.ADOp_CloseCon(0) If x.ADOo_errstring <> "" Then MsgBox (x.ADOo_errstring) Exit Sub End If '--------------------------setup an output sheet if necessary------------------------------- For Each ws In Application.Worksheets For Each cp In ws.CustomProperties If cp.Name = "spec_name" And cp.value = "price_list" Then Set new_sh = ws End If Next cp Next ws If new_sh Is Nothing Then Set new_sh = Application.Worksheets.Add Call new_sh.CustomProperties.Add("spec_name", "price_list") End If '-------------------------dump contents------------------------------------------------------ Call x.SHTp_Dump(cms_pl, new_sh.Name, 1, 1, True, True) new_sh.Select ActiveSheet.Cells(1, 1).CurrentRegion.Select Selection.Columns.AutoFit Rows("1:1").Select With ActiveWindow .SplitColumn = 0 .SplitRow = 1 End With ActiveWindow.FreezePanes = True '--------------------------format source cells for any build issues-------------------------------- orig.Worksheet.Select With orig.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With For i = 1 To UBound(cms_pl, 1) Select Case cms_pl(i, 9) Case "" Case "no unit conversion" orig.Worksheet.Cells(orig.row + cms_pl(i, 10) - 1, orig.column + cms_pl(i, 11) - 1).Interior.Color = RGB(255, 255, 161) Case "no part number" orig.Worksheet.Cells(orig.row + cms_pl(i, 10) - 1, orig.column + cms_pl(i, 11) - 1).Interior.Color = RGB(220, 220, 220) End Select Next i '----------------------------cleanup------------------------------------------------------------- Set x = Nothing 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 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 End If Next cp Next ws Set orig = Application.Selection Selection.CurrentRegion.Select trow = orig.row - Selection.row + 1 tcol = orig.column - Selection.column + 1 i = 1 Do Until price_sheet.Cells(i, 1) = "" If price_sheet.Cells(i, 11) = trow And price_sheet.Cells(i, 12) = tcol Then price_sheet.Select ActiveSheet.Cells(i, 10).Select Exit Sub End If i = i + 1 Loop End Sub Sub build_price_upload() Dim x As New TheBigOne Dim pl() As String Dim i As Long Dim j As Long Dim ul() As String Dim pl_code As String Dim pl_action As String Dim pl_d1 As String Dim pl_d2 As String Dim pl_d3 As String Dim fd As FileDialog pl = x.SHTp_GetString(Selection) ReDim ul(10, UBound(pl, 2)) PRICELIST_SHOW: pricelist.Show pl_code = pricelist.tbCODE.Text pl_d1 = pricelist.tbD1.Text pl_d2 = pricelist.tbD2.Text pl_d3 = pricelist.tbD3.Text pl_action = "2" If Len(pricelist.tbCODE) > 5 Then MsgBox ("price code must be 5 or less characters") GoTo PRICELIST_SHOW End If 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 = 1 For i = LBound(pl, 2) + 1 To UBound(pl, 2) ul(0, j) = "DTL" ul(1, j) = pl_code ul(2, j) = pl(7, i) ul(3, j) = pl(5, i) ul(4, j) = pl(4, i) ul(5, j) = pl(6, i) ul(10, j) = "2" j = j + 1 Next i '--------Open file------------- If Not x.FILEp_CreateCSV(pricelist.tbPATH.Text & "\" & pl_code & ".csv", ul) Then MsgBox ("error") End If Excel.Workbooks.Open (pricelist.tbPATH.Text & "\" & pl_code & ".csv") '---------------------header row--------------------------------- End Sub