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
    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, True))

End Sub

Sub sql_from_range_pg_qh_all()

    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, True, "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A", "A"))

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.0.10.40", 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.0.10.40", 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
    
    '---------------------------postgres------------------------------
    
    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", "S", "A", "A", "J", "S")
    sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";"
    sql = sql & vbCrLf & "REFRESH MATERIALIZED VIEW rlarp.molds;"
    sql = sql & vbCrLf & "COMMIT;"
    
    If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidsap02", 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)

    'Exit Sub
    
    '---------------------------sql server------------------------------

    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", "S", "A", "A", "A", "S")
    sql = "BEGIN" & vbCrLf & "DELETE FROM rlarp.price_map;" & vbCrLf & "INSERT INTO rlarp.price_map" & vbCrLf & sql & ";" & vbCrLf & "END"

    If Not x.ADOp_Exec(1, sql, 1, True, ADOinterface.SqlServer, "usmidsql01", True) Then
        MsgBox (x.ADOo_errstring)
    Else
        'MsgBox ("Upload Complete")
    End If

    Call x.ADOp_CloseCon(1)

    Set x = Nothing
    
    '---------------------------iSeries------------------------------

    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, False, True, Db2, False, True, i, i + inc, "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "A", "A", "A", "S")
        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.0.10.40", 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.0.10.40", 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.0.10.40", 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
    
    '---------------postgrs-------------------
    
    login.Caption = "Postgres Creds"
    login.Show
    If Not login.proceed Then Exit Sub
    
    If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.0.10.40", False, login.tbU, login.tbP, "database=ubm") Then
        MsgBox (x.ADOo_errstring)
        Exit Sub
    End If
    
    Call x.ADOp_CloseCon(0)
    
    '---------------iSereis-------------------
    
    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(1, sql) Then
        MsgBox (x.ADOo_errstring)
        Exit Sub
    End If
    
    '---------------mssql-------------------
    
    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, SqlServer, False, True, "A", "A") & ";"
    sql = sql & vbCrLf & " END"
    
    If Not x.ADOp_OpenCon(2, SqlServer, "usmidsap01", True) Then
        MsgBox (x.ADOo_errstring)
        Exit Sub
    End If
    
    If Not x.ADOp_Exec(2, 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