VBA/FL.bas

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

    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_db2_qh()

    Dim x As New TheBigOne
    Dim wapi As New Windows_API
    Dim r() As String
    Selection.CurrentRegion.Select
    Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, True))

End Sub

Sub sql_from_range_db2_noqh()

    Dim x As New TheBigOne
    Dim wapi As New Windows_API
    Dim r() As String
    Selection.CurrentRegion.Select
    Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, Db2, False))

End Sub

Sub sql_from_range_pg_qh()

    Dim x As New TheBigOne
    Dim wapi As New Windows_API
    Dim r() As String
    Selection.CurrentRegion.Select
    Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, True))

End Sub

Sub sql_from_range_pg_noqh()

    Dim x As New TheBigOne
    Dim wapi As New Windows_API
    Dim r() As String
    Selection.CurrentRegion.Select
    Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False))

End Sub

Sub auto_fit_range()
    
    Selection.CurrentRegion.Columns.AutoFit

End Sub

Sub pivot_field_format()
Attribute pivot_field_format.VB_ProcData.VB_Invoke_Func = "F\n14"

    ActiveSheet.PivotTables(1).PivotFields(ActiveCell.value).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"

End Sub

Sub 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(8, (UBound(tbl, 2) - 1) * (UBound(tbl, 1) - 4))
    For i = 5 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) 'color code/tier (row one, column j)
            unp(2, k) = tbl(2, j) 'size code (row two, column j)
            unp(3, k) = tbl(3, j) 'volue break uom (row 3, column j)
            unp(4, k) = Format(tbl(4, j), "#.00") 'volue break qty (row 4, column j)
            unp(5, k) = "M" 'pricing unit of measuer
            unp(6, k) = Format(tbl(i, j), "#.00") 'price (row i, column j)
            unp(7, k) = i
            unp(8, k) = j
        Next j
    Next i
    unp(0, 0) = "mold"
    unp(1, 0) = "sizc"
    unp(2, 0) = "color"
    unp(3, 0) = "vbuom"
    unp(4, 0) = "vbqty"
    unp(5, 0) = "puom"
    unp(6, 0) = "price"
    unp(7, 0) = "orig_row"
    unp(8, 0) = "orig_col"
    
    If Not x.TBLp_TestNumeric(unp, 4) Then
        MsgBox ("volume break quantity is text")
        Exit Sub
    End If
    
    If Not x.TBLp_TestNumeric(unp, 6) Then
        MsgBox ("price is text")
        Exit Sub
    End If
    
    '-------------------------prepare sql to upload---------------------------------------------------------------
    
    sql = x.SQLp_build_sql_values(unp, False, True, Db2, False)
    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, 13)
            Case ""
            Case "no unit conversion"
                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
            Case "no part number"
                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 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
    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()

    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 = "1"
    
    If Len(pricelist.tbCODE) > 5 Then
        MsgBox ("price code must be 5 or less characters")
        GoTo PRICELIST_SHOW
    End If
    
    If Not pricelist.cbInactive Then
        Call x.TBLp_FilterSingle(pl, 11, "I", False)
    End If
    
    If Not pricelist.cbNonStocked Then
        Call x.TBLp_FilterSingle(pl, 10, "A", True)
    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 = 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(12, i) <> "" And pl(13, i) <> "" And pl(8, i) <> "" And pl(9, i) <> "" Then
            j = j + 1
            ul(0, j) = "DTL"                                                                'DTL
            ul(1, j) = pl_code                                                              'Price list code
            ul(2, j) = pl(9, i)                                                             'part number
            ul(3, j) = pl(7, i)                                                             'price unit
            ul(4, j) = Format(CDbl(pl(6, i)) * CDbl(pl(12, i)) / CDbl(pl(13, i)), "0.00")   'volume break in price uom
            ul(5, j) = Format(pl(8, i), "0.00")                                             'price
            ul(11, j) = "1"                                                                 'add, update, delete
        End If
    Next i
    
    ReDim Preserve ul(11, j)

    
    '--------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