From aa88dbc9e7ae49cd87d44fdd7f9b7eefaccd3936 Mon Sep 17 00:00:00 2001 From: Trowbridge Date: Mon, 13 Jan 2020 17:23:39 -0500 Subject: [PATCH] upper bound was wrong --- FL.bas | 2004 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 1002 insertions(+), 1002 deletions(-) diff --git a/FL.bas b/FL.bas index bca8194..ff3447d 100644 --- a/FL.bas +++ b/FL.bas @@ -1,1002 +1,1002 @@ -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 +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(11, 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