VBA/PriceLists.bas

Attribute VB_Name = "PriceLists"
Option Explicit

Public tbo As New TheBigOne


Sub test_full20()

    '------------------------------------setup-------------------------------------------------

    Dim wapi As New Windows_API
    Dim x As New TheBigOne
    Dim tbl() As Variant
    Dim lists() As String
    Dim pcol() As Long
    Dim unp() As String
    Dim unv() As Variant
    Dim onelist() As String
    Dim i As Long
    Dim l As Long
    Dim j As Long
    
    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

    Set ini = Application.Selection
    Selection.CurrentRegion.Select
    Set orig = Application.Selection
    
    unp = unpivot_current_sheet(lists, pcol)
    
    login.Caption = "PostgreSQL Login"
    login.tbU = "report"
    login.tbP = "report"
    login.Show
    If Not login.proceed Then Exit Sub
    
    If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm") Then
        MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    With orig.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    For l = 1 To UBound(lists)
        '----------filter the main data set for each price lists (due to json_from_table taking forever on big tables)--------
        onelist = unp
        Call x.TBLp_FilterSingle(onelist, 9, lists(l), True)
        onelist = x.TBLp_Transpose(onelist)
        unv = x.TBLp_StringToVar(onelist)
    
        '-------------------------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.plcore_fullcode_inq($$" & sql & "$$::jsonb)"
        Call wapi.ClipBoard_SetData(sql)
        
        'If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
        'Exit Sub
        cms_pl = x.ADOp_SelectS(0, sql, True, 50000, True)

        '--------------------------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.Activate
        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
        '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), orig.column + cms_pl(i, 14)).Interior.ThemeColor = xlThemeColorAccent6
                Case "No UOM Conversion"
                    If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
                        orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 255, 161)
                    End If
                Case "Inactive"
                    If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
                        orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.Color = RGB(255, 20, 161)
                    End If
                Case "No SKU"
                    If orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).Interior.ThemeColor <> xlThemeColorAccent6 Then
                        orig.Worksheet.Cells(orig.row + cms_pl(i, 13), orig.column + cms_pl(i, 14)).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
        
    Next l
    
    Call x.ADOp_CloseCon(0)
    
    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
            'flag any cells that have prices that are not a formula
            If IsNumeric(cell.value) And Mid(cell.Formula, 1, 1) <> "=" And cell.row > 3 And cell.column > 6 Then
                'cell.Interior.Color = RGB(186, 85, 211)
'                With cell.Borders(xlEdgeLeft)
'                    .LineStyle = xlContinuous
'                    .Color = -6279056
'                    .TintAndShade = 0
'                    .Weight = xlThick
'                End With
'                With cell.Borders(xlEdgeTop)
'                    .LineStyle = xlContinuous
'                    .Color = -6279056
'                    .TintAndShade = 0
'                    .Weight = xlThick
'                End With
'                With cell.Borders(xlEdgeRight)
'                    .LineStyle = xlContinuous
'                    .Color = -6279056
'                    .TintAndShade = 0
'                    .Weight = xlThick
'                End With
'                With cell.Borders(xlEdgeBottom)
'                    .LineStyle = xlContinuous
'                    .Color = -6279056
'                    .TintAndShade = 0
'                    .Weight = xlThick
'                End With
            End If
            cell.Interior.Pattern = xlNone
        Else
            If cell.Interior.Pattern = xlNone And cell.value <> "" Then
                '---yellow-------
                cell.Interior.Color = RGB(255, 255, 161)
            End If
        End If
    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
    For i = 1 To UBound(pcol)
        Selection.Columns(pcol(i) + 1).Interior.Pattern = xlNone
    Next i

    Application.ScreenUpdating = True
    
    '----------------------------cleanup-------------------------------------------------------------
    
    Set x = Nothing
    
    ini.Select
    
    
End Sub

Sub price_load_plcore()

    Dim x As New TheBigOne      'function library
    Dim load() As String        'individual price list to be loaded
    Dim pcol() As Long          'hold the positions of each price list
    Dim plist() As String
    Dim i As Long               'walks through each price list
    Dim j As Long               'walks through each original row
    Dim k As Long               'creates new rows for each price break
    Dim m As Long               'row position in the new table
    Dim sql As String
    
    '---current setup takes 2 minutes. need to break into smaller uploads, one price list per round--
    
    '-------identify the active sheet and load the contents to an array-----------
    
    load = unpivot_current_sheet(plist, pcol)
    '-------filter out any -0- prices before loading
    Call x.TBLp_FilterSingle(load, 8, "0.00", False)
    
    '------if no columns are labeled plist then exit------------------------------
    
    If UBound(pcol) = 0 Then Exit Sub
    
    '------clear out overlapping price lists--------------------------------------
    
    sql = ""
    For i = 1 To UBound(plist)
        If i > 1 Then
            sql = sql & ",'" & plist(i) & "'"
        Else
            sql = sql & "'" & plist(i) & "'"
        End If
    Next i
    sql = "DELETE FROM rlarp.plcore WHERE listcode in (" & sql & ");"
    sql = sql & vbCrLf & "INSERT INTO rlarp.plcore"
    sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S", "N", "N") & ";"
    
    login.Caption = "Postgres Login"
    login.tbU = LCase(Mid(Application.UserLibraryPath, 10, InStr(10, Application.UserLibraryPath, "\") - 10))
    login.Show
    If Not login.proceed Then Exit Sub
    
    If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU, login.tbP, "Port=5432;Database=ubm") Then
        MsgBox (x.ADOo_errstring)
        Exit Sub
    End If
    
    'If Not x.ADOp_Exec(1, sql, 1, True, ADOinterface.SqlServer, "mid-sql02", True) Then
    '    MsgBox (x.ADOo_errstring)
    '    Exit Sub
    'End If
    
    
End Sub




Sub build_csv()

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

Function unpivot_current_sheet(ByRef lists() As String, ByRef pcol() As Long) As String()

    Dim x As New TheBigOne      'function library
    Dim sh As Worksheet         'target worksheet
    Dim big() As String         'all price lists in one array
    Dim unpivot() As String     'unwrap the columns into volume level rows
    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
    ReDim lists(30)
    Dim dcol() As Integer       'columns to be deleted
    Dim typeflag() As String    'array of column types
    Dim i As Long               'walks through each price list
    Dim j As Long               'walks through each original row
    Dim k As Long               'creates new rows for each price break
    Dim m As Long               'row position in the new table
    Dim sql As String
    
    '-------identify the active sheet and load the contents to an array-----------
    
    Set sh = ActiveSheet
    big = x.SHTp_Get(sh.Name, 3, 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
            lists(pcount) = big(i, 1)
        End If
    Next i
    
    '------if no columns are labeled plist then exit------------------------------
    
    If pcount = 0 Then Exit Function
    ReDim Preserve pcol(pcount)
    ReDim Preserve lists(pcount)
    ReDim typeflag(9)
    
    
    '----since there are 3 price columns, those will need transformed to 3 price rows per each original-----
    ReDim load(11, UBound(big, 2) * 3 * pcount)
    m = 1
    '----set headers-----
    load(0, 0) = "stlc"
    load(1, 0) = "coltier"
    load(2, 0) = "branding"
    load(3, 0) = "accs"
    load(4, 0) = "suffix"
    load(5, 0) = "uomp"
    load(6, 0) = "vol_uom"
    load(7, 0) = "vol_qty"
    load(8, 0) = "vol_price"
    load(9, 0) = "listcode"
    load(10, 0) = "orig_row"
    load(11, 0) = "orig_col"
        
    For pcount = 1 To UBound(pcol)
        '-----populate------------
        For i = 1 To UBound(big, 2)
            '-----hard coded to number of price breaks (3)-------
            For k = 0 To 2
                load(0, m) = big(0, i)
                load(1, m) = big(1, i)
                load(2, m) = big(2, i)
                load(3, m) = big(3, i)
                load(4, m) = big(4, i)
                '----position 3 is a bulk pallet so the default UOM needs hard coded to PLT-----
                If k = 2 Then
                    load(5, m) = "PLT"
                Else
                    load(5, m) = big(5, i)
                End If
                '----(3-k) should work out to 1st 2nd 3rd price colum----------------------------
                '----the first column UOM is the default package, everything else is a pallet----
                If k = 0 Then
                    load(6, m) = big(5, i)
                Else
                    load(6, m) = "PLT"
                End If
                '----for now the volumes are always 1 of the unit of measure in colunm 6 above
                load(7, m) = "1"
                load(8, m) = Format(big(pcol(pcount) - (3 - k), i), "####0.00")
                load(9, m) = big(pcol(pcount) - 0, i)
                load(10, m) = i
                load(11, m) = pcol(pcount) - (3 - k)
                m = m + 1
            Next k
        Next i
    Next pcount
    
    If Not x.TBLp_TestNumeric(load, 8) Then
        MsgBox ("price is text")
        Exit Function
    End If
    
    unpivot_current_sheet = load

End Function


Sub build_customer_files()

    Dim x As New TheBigOne
    Dim i As Long
    Dim pl() As String
    Dim pln() As String
    Dim plf() As String
    Dim fc() As String
    Dim nwb As Workbook
    Dim fcwb As Workbook
    Dim nws As Worksheet
    Dim nnws As Worksheet
    Dim nfws As Worksheet
    Dim fcws As Worksheet
    Dim filepath As String
    Dim clist() As String
    Dim plev As String
    Dim effdate As Date
    Dim segment_regex As String
    Dim curr As String
    Dim fname As String
    
    '----------------------pick price level---------------------------------------------------------------------
    login.Caption = "PostgreSQL Login"
    login.tbU = "report"
    login.tbP = "report"
    login.proceed = True
    'login.Show
    If Not login.proceed Then Exit Sub
    Call pricelevel.repopulate
    pricelevel.Show
    If pricelevel.cancel Then Exit Sub
    If Not IsDate(pricelevel.tbEddDate.text) Then
        MsgBox ("cannot interperet date - " & pricelevel.tbEddDate.text)
        Exit Sub
    End If
    
    For i = 0 To pricelevel.lbPriceLev.ListCount - 1
        If pricelevel.lbPriceLev.Selected(i) Then
            plev = pricelevel.lbPriceLev.list(i)
            Call build_price_level(plev)
        End If
    Next i
    
    
    
    End Sub
    
    
Sub build_price_level(plev As String)

    Dim x As New TheBigOne
    Dim i As Long
    Dim pl() As String
    Dim pln() As String
    Dim plf() As String
    Dim fc() As String
    Dim nwb As Workbook
    Dim fcwb As Workbook
    Dim nws As Worksheet
    Dim nnws As Worksheet
    Dim nfws As Worksheet
    Dim fcws As Worksheet
    Dim filepath As String
    Dim effdate As Date
    Dim clist() As String
    Dim segment_regex As String
    Dim curr As String
    Dim fname As String
    
    effdate = CDate(pricelevel.tbEddDate.text)
    filepath = pricelevel.tbPATH & "\" & plev
    
    If pricelevel.chbFULLCODE Then
        '---------------------get full code list--------------------------------------------------------------------
        fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
        If fc(0, 0) <> "Currency" Then
            MsgBox (fc(0, 0))
            Exit Sub
        End If
        
        '---------------------create new workbook-------------------------------------------------------------------
        If UBound(fc, 2) = 0 Then
            'MsgBox ("no full code list data for " & plev)
            Exit Sub
        End If
        Application.ScreenUpdating = False
        Set fcwb = Application.Workbooks.Add
        fcwb.Activate
        Set fcws = fcwb.Sheets(1)
        fcws.Activate
        'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric
        Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14)
        Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        
        '--------------------format full code------------------------------------------------------------------------
        Application.CutCopyMode = False
        fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing"
        fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21"
        fcws.Cells.Font.Name = "Courier New"
        fcws.Cells.Font.Size = 10
        With fcws.Rows(3)
            .WrapText = True
            .RowHeight = 40.5
        End With
        fcws.Columns("A").ColumnWidth = 9.43
        fcws.Columns("B").ColumnWidth = 20
        fcws.Columns("C:D").ColumnWidth = 35
        fcws.Columns("E").ColumnWidth = 21.5
        fcws.Columns("F").ColumnWidth = 3.71
        fcws.Columns("G").ColumnWidth = 9.43
        fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
        fcws.Columns("H").ColumnWidth = 7.14
        fcws.Columns("I:P").ColumnWidth = 14
        fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
        fcws.Columns("O").ColumnWidth = 10.57
        fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
        Rows("3:3").NumberFormat = "General"
        fcws.Activate
        ActiveWindow.DisplayGridlines = False
        Rows("4:4").Select
        ActiveWindow.FreezePanes = True
        fcws.ListObjects("Full Code Listing").ShowAutoFilter = False
        
        '---------------------logo----------------------------------------------------------------------------------
        fcws.Rows("1:2").RowHeight = 28.5
        fcws.Cells(1, 1).Select
        ActiveSheet.Pictures.Insert("https://hccompanies.sharepoint.com/_layouts/15/download.aspx?UniqueId=2ee21088%2Ddad1%2D41aa%2Daf65%2D14b44c46941e").Select
        'Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
        Selection.ShapeRange.ScaleWidth 0.375, msoFalse, msoScaleFromTopLeft
        'Selection.ShapeRange.ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft
        'Selection.ShapeRange.IncrementLeft 2
        'Selection.ShapeRange.IncrementTop 2
        ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
        ActiveSheet.Cells(5, 1).Select
        fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY")
        fcws.Name = "Full Code Listing"
        fcws.Cells(3, 1).Select
    End If

    'Application.ScreenUpdating = True
    'Exit Sub
    
    '---------------------create new workbook-------------------------------------------------------------------
    Set nwb = Application.Workbooks.Add
    nwb.Activate
    Set nws = nwb.Sheets(1)
    segment_regex = "^G|^N|^F|^P"
    
    '---------------------get price list------------------------------------------------------------------------
    If pricelevel.chbNURSERY Then
        pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
        If pln(0, 0) <> "Product" Then
            MsgBox (pln(0, 0))
            Exit Sub
        End If
        If UBound(pln, 2) > 21 Then
            segment_regex = "^F|^G|^P"
            Set nnws = nwb.Sheets.Add(, nws)
            nnws.Name = "Price List - Nursery"
            Call paste_pretty(pln, nnws, effdate, curr)
        End If
    End If
    
    If pricelevel.chbFIBER Then
        plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
        If plf(0, 0) <> "Product" Then
            MsgBox (plf(0, 0))
            Exit Sub
        End If
        If UBound(plf, 2) > 21 Then
            If segment_regex = "^F|^G|^P" Then
                segment_regex = "^G|^P"
            Else
                segment_regex = "^G|^N|^P"
            End If
            Set nfws = nwb.Sheets.Add(, nws)
            nfws.Name = "Price List - Fiber"
            Call paste_pretty(plf, nfws, effdate, curr)
        End If
    End If
    
    pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "10.56.60.254", False, login.tbU.text, login.tbP.text, "Port=5432;Database=ubm")
    If pl(0, 0) <> "Product" Then
        MsgBox (pl(0, 0))
        Exit Sub
    End If
    If UBound(pl, 2) > 21 Then
        nws.Name = "Price list"
        Call paste_pretty(pl, nws, effdate, curr)
    Else
        nws.Delete
    End If
    
    Application.ScreenUpdating = True
    
    '--------------------save file--------------------------------------------------------------------------------
    'Dim fd As Object
    'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    'fd.Show
    'If fd.SelectedItems.Count = 0 Then Exit Sub
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(filepath) Then .CreateFolder filepath
    End With
    Application.DisplayAlerts = True
    nwb.Activate
    
    fname = "HC Companies Distributor Price List " & curr & ".xlsx"
    
    Dim wb As Workbook
    For Each wb In Workbooks
        If wb.Name = fname Then
            If MsgBox("already have a price list open, close it?", vbOKCancel) Then
                Workbooks(fname).Close
                Exit For
            Else
                Exit Sub
            End If
        End If
    Next wb
    
    If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\" & fname
    
    If pricelevel.chPDF Then
        fname = Replace(fname, "xlsx", "pdf")
        nwb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=filepath & "\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End If
    
    If Not pricelevel.chbLEAVEOPEN Then
        nwb.Close
    End If

    For Each wb In Workbooks
        If wb.Name = "HC FullCode List.xlsx" Then
            If MsgBox("already have a full code list open, close it?", vbOKCancel) Then
                Workbooks("HC FullCode List.xlsx").Close
                Exit For
            Else
                Exit Sub
            End If
        End If
    Next wb
    
    If Not (fcwb Is Nothing) Then
        If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx"
        If Not pricelevel.chbLEAVEOPEN Then
            fcwb.Close
        End If
    End If

    
End Sub

Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date, ByRef curr As String)

    Dim c As Range
    Dim i As Long
    Dim last As Long
    Dim lastcol As Long
    Dim j As Long

    nws.Activate
    nws.Cells.NumberFormat = "@"
    '---------------------format to numeric if selected---------------------------------------------------------
    If pricelevel.cbNUMERIC Then
        Call tbo.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16)
        nws.Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        nws.Columns(10).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(13).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(16).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(11).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(14).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(17).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
        nws.Columns(10).ColumnWidth = 13
        nws.Columns(13).ColumnWidth = 13
        nws.Columns(16).ColumnWidth = 13
        nws.Rows(5).NumberFormat = "@"
    Else
        Call tbo.SHTp_Dump(pl, nws.Name, 5, 1, False, True)
        nws.Columns(10).ColumnWidth = 10.57
        nws.Columns(13).ColumnWidth = 10.57
        nws.Columns(16).ColumnWidth = 10.57
    End If
    
    Application.ScreenUpdating = False
    
    '---------------------whole sheet formatting----------------------------------------------------------------
    nws.Columns(9).HorizontalAlignment = xlRight
    nws.Columns(10).HorizontalAlignment = xlRight
    nws.Columns(11).HorizontalAlignment = xlRight
    nws.Columns(12).HorizontalAlignment = xlRight
    nws.Columns(13).HorizontalAlignment = xlRight
    nws.Columns(14).HorizontalAlignment = xlRight
    nws.Columns(15).HorizontalAlignment = xlRight
    nws.Columns(16).HorizontalAlignment = xlRight
    nws.Columns(17).HorizontalAlignment = xlRight
    nws.Columns(1).ColumnWidth = 12
    nws.Columns(2).ColumnWidth = 70
    nws.Columns(3).ColumnWidth = 8.29
    nws.Columns(4).ColumnWidth = 4.86
    nws.Columns(5).ColumnWidth = 4.86
    nws.Columns(6).ColumnWidth = 4.86
    nws.Columns(7).ColumnWidth = 4.86
    If pricelevel.chbColors Then
        nws.Columns(8).ColumnWidth = 17
        nws.Columns(8).WrapText = True
    Else
        nws.Columns(8).ColumnWidth = 11
    End If
    nws.Columns(9).ColumnWidth = 8.29
    nws.Columns(9).WrapText = True
    nws.Columns(12).ColumnWidth = 8.29
    nws.Columns(12).WrapText = True
    nws.Columns(15).ColumnWidth = 8.29
    nws.Columns(15).WrapText = True
    nws.Columns(11).ColumnWidth = 11.71
    nws.Columns(14).ColumnWidth = 11.71
    nws.Columns(17).ColumnWidth = 13
    ActiveWindow.DisplayGridlines = False
    'nws.Cells.Font.Name = "Cascadia Code Light"
    nws.Cells.Font.Name = "Courier New"
    nws.Cells.Font.Size = 10
    Rows("6:6").Select
    ActiveWindow.FreezePanes = True
        
    '---------------------logo----------------------------------------------------------------------------------
    ActiveSheet.Cells(1, 1).Select
    ActiveSheet.Pictures.Insert("https://hccompanies.sharepoint.com/_layouts/15/download.aspx?UniqueId=2ee21088%2Ddad1%2D41aa%2Daf65%2D14b44c46941e").Select
    'Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 0.375, msoFalse, msoScaleFromTopLeft
    'Selection.ShapeRange.ScaleHeight 0.52, msoFalse, msoScaleFromTopLeft
    'Selection.ShapeRange.IncrementLeft 2
    'Selection.ShapeRange.IncrementTop 2
    ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
    ActiveSheet.Cells(5, 1).Select
    
    '---------------------header formatting---------------------------------------------------------------------
    For Each c In Range("I5:Q5").Cells
        c.value = Left(c.value, Len(c.value) - 1)
    Next c
    Application.DisplayAlerts = False
    With nws.Range("I4")
        .value = "------Single Package------"
        .HorizontalAlignment = xlLeft
        .InsertIndent 1
        .WrapText = False
    End With
    With nws.Range("L4")
        .value = "--------Full Pallet-------"
        .HorizontalAlignment = xlLeft
        .InsertIndent 1
        .WrapText = False
    End With
    With nws.Range("O4")
        .value = "--------Bulk Pallet-------"
        .HorizontalAlignment = xlLeft
        .InsertIndent 1
        .WrapText = False
    End With
    Application.DisplayAlerts = True
    
    '---------------------find size of table---------------------------------------------------------------------
    i = 6
    Do Until nws.Cells(i, 18) = ""
        i = i + 1
    Loop
    last = i - 1
    lastcol = 17
    
    '--------------------line formatting--------------------------------------------------------------------------
    For i = 6 To last
        '--------------------format header---------------
        If nws.Cells(i, 18) = "header" Then Call header(nws, i, 1, lastcol)
        '--------------------create bands---------------
        If nws.Cells(i, 20) = "1" And Not nws.Cells(i, 18) = "header" Then Call banding(nws, i, 1, lastcol)
        '--------------------indent compatible---------------
        If nws.Cells(i, 18) = "compatible" Then Call compatible(nws, i, 1, 2)
        '--------------------highlight price---------------
        If nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible" Then Call price_col(nws, i, 20)
        '--------------------comment empy qty to prevent colors from spilling
        If nws.Cells(i, 9) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 9) = "'"
        If nws.Cells(i, 11) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 11) = "'"
        If nws.Cells(i, 12) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 12) = "'"
        If nws.Cells(i, 14) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 14) = "'"
        If nws.Cells(i, 15) = "" And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then nws.Cells(i, 15) = "'"
        '-------------------apply border------------------
        If pricelevel.chbBorders And (nws.Cells(i, 18) = "base" Or nws.Cells(i, 18) = "compatible") Then Call border(nws, i, lastcol)
        '--------------------merge products---------------
        If nws.Cells(i, 1) = nws.Cells(i - 1, 1) And nws.Cells(i, 1) <> nws.Cells(i + 1, 1) Then
            'if the next row is different and the previous row is the same the loop back and merge the range
            j = -1
            Do Until nws.Cells(i + j, 1) <> nws.Cells(i, 1)
                j = j - 1
            Loop
            j = j + 1
            If j < 0 Then Call merge(nws, i + j, i)
        End If
        '-------------------auto fit row for wrapped colors-------
        nws.Rows(i).EntireRow.autofit
        '-------------------reformat line breaks----------
        'nws.Cells(i, 9) = split_and_rebuild(nws.Cells(i, 9))
        'nws.Cells(i, 12) = split_and_rebuild(nws.Cells(i, 12))
        'nws.Cells(i, 15) = split_and_rebuild(nws.Cells(i, 15))
            
    Next i
    
    '--------------------print header data--------------------------------------------------------------------------
    pl = tbo.TBLp_Transpose(pl)
    Call tbo.TBLp_FilterSingle(pl, 20, "", False)
    Call tbo.TBLp_Group(pl, True, tbo.ARRAYp_MakeInteger(20))
    If UBound(pl, 2) > 1 Then
        '---somehow multiple currencies involved----
        MsgBox ("multiple currencies")
        Exit Sub
    Else
        Select Case pl(20, 1)
            Case "C"
                curr = "CAD"
            Case "U"
                curr = "USD"
            Case Else
                MsgBox ("unknown currency - " & pl(20, 1))
        End Select
    End If
    nws.Cells(2, 3).value = "Distributor Price List (" & curr & ") - Effective " & Format(effdate, "MM/DD/YYYY")
    nws.Cells(5, 1).Select
    
    Call print_setup(nws, last)
    
    nws.Columns("R:V").Delete



End Sub

Function rrange(ByRef sheet As Worksheet, start_row As Long, end_row As Long, start_col As Long, end_col As Long) As Range

    Set rrange = Range(sheet.Cells(start_row, start_col).address & ":" & sheet.Cells(end_row, end_col).address)

End Function

Sub price_col(ByRef sheet As Worksheet, row As Long, flag_col As Long)

    Dim Sel As Range
    Dim i As Long
    
    i = 0
    Do Until i = 9
        Set Sel = rrange(sheet, row, row, 10 + i, 10 + i)

        If sheet.Cells(row, flag_col) = "0" Then
            With Sel.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.799981688894314
                .PatternTintAndShade = 0
            End With
        Else
            With Sel.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent4
                .TintAndShade = 0.599993896298105
                .PatternTintAndShade = 0
            End With
        End If
        i = i + 3
    Loop


End Sub


Sub merge(ByRef ws As Worksheet, start_row As Long, end_row As Long)

    Dim Sel As Range
    Dim i As Long
    
    Application.DisplayAlerts = False

    For i = 1 To 2
        Set Sel = rrange(ws, start_row, end_row, i, i)
        
        With Sel
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
    Next i
    
    Application.DisplayAlerts = True
    
End Sub

Sub compatible(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)

    Dim Sel As Range
    
    Set Sel = rrange(ws, row, row, start_col, end_col)
    
    Sel.InsertIndent 2

End Sub

Sub banding(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)

    Dim Sel As Range
    
    Set Sel = rrange(ws, row, row, start_col, end_col)
    
    With Sel.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    

End Sub

Sub header(ByRef ws As Worksheet, row As Long, start_col As Long, end_col As Long)

    Dim Sel As Range
    
    Set Sel = rrange(ws, row, row, start_col, end_col)

    Sel.InsertIndent 2
    Sel.Font.Size = 11
    With Sel.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Sel.Borders(xlDiagonalDown).LineStyle = xlNone
    Sel.Borders(xlDiagonalUp).LineStyle = xlNone
    With Sel.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Sel.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Sel.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Sel.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThick
    End With
    Sel.Borders(xlInsideVertical).LineStyle = xlNone
    Sel.Borders(xlInsideHorizontal).LineStyle = xlNone


End Sub

Sub border(ByRef ws As Worksheet, row As Long, lastcol As Long)

    Dim target As Range
    Set target = ws.Range(ws.Cells(row, 1), ws.Cells(row, lastcol))
    If ws.Cells(row - 1, 18) <> "header" Then
        With target.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ThemeColor = 1
            .TintAndShade = -0.249946592608417
            .Weight = xlThin
        End With
    End If
    With target.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
        With target.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With

End Sub

Function split_and_rebuild(text As String) As String

    Dim i As Long
    Dim last As Long
    Dim newt As String
    
    newt = ""
    i = 1
    last = 1
    Do Until InStr(i, text, Chr(10)) = 0
        i = InStr(i, text, Chr(10))
        newt = newt & Mid(text, last, i - 1) & Chr(10)
        last = i
        i = i + 1
    Loop
    newt = newt & Mid(text, i, 100)
    split_and_rebuild = newt
    

End Function


Sub print_setup(sheet As Worksheet, last_row As Long)

    Dim Sel As Range
    Dim i As Long
    Dim j As Long
    
    Set Sel = rrange(sheet, 6, last_row, 1, 17)
    
    Application.PrintCommunication = False

    With sheet.PageSetup
        .PrintArea = Sel.address
        .PrintTitleRows = "$1:$5"
        '.FitToPagesTall = 0
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.25)
        .BottomMargin = Application.InchesToPoints(0.25)
        .HeaderMargin = Application.InchesToPoints(0.25)
        .FooterMargin = Application.InchesToPoints(0.25)
        .Orientation = xlLandscape
        .FitToPagesWide = 1
    End With
    
    sheet.PageSetup.FitToPagesWide = 1
    sheet.PageSetup.FitToPagesTall = 0
    
    
    '-------------------force a page break on color codes----------
    j = 1
    For i = 5 To last_row
        If j >= 810 Then
            sheet.HPageBreaks.Add before:=sheet.Rows(i + 1)
            j = 1
        End If
        'every 73 rows is a page break for current font, but if a row is taller this needs accounted for
        If sheet.Cells(i, 18) = "colors" And sheet.Cells(i - 1, 18) <> "colors" Then
            sheet.HPageBreaks.Add before:=sheet.Rows(i)
            j = 1
        End If
        If sheet.Cells(i, 18) = "notes" And sheet.Cells(i - 1, 18) <> "notes" Then
            sheet.HPageBreaks.Add before:=sheet.Rows(i)
            j = 1
        End If
        j = j + sheet.Rows(i).RowHeight
    Next i
    
    sheet.DisplayPageBreaks = False
    
    Application.PrintCommunication = True
    
    sheet.DisplayPageBreaks = False
    
End Sub

Public Function plevel_segment(plevel As String, segment_num As Integer) As String

    Dim ret() As String

    ret = tbo.TXTp_ParseCSV(plevel, ".")
    
    If segment_num - 1 > UBound(ret) Then
        plevel_segment = ""
    Else
        plevel_segment = ret(segment_num - 1)
    End If

End Function