move colors to columns, and update the highlighting

FL.bas

@@ -385,6 +385,37 @@ Sub json_from_table()
 
 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"
 
@@ -665,6 +696,13 @@ Attribute pivot_field_format.VB_ProcData.VB_Invoke_Func = "F\n14"
 
 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 Write_selection()
     Dim P As FileDialog
 
@@ -928,7 +966,7 @@ Sub extract_price_matrix()
             Case "no unit conversion"
                 orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
             Case "no part number"
-                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
+                'orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(220, 220, 220)
         End Select
     Next i
     
@@ -938,6 +976,215 @@ Sub extract_price_matrix()
     
 End Sub
 
+Sub extract_price_matrix_r1()
+
+    '------------------------------------setup-------------------------------------------------
+
+    Dim wapi As New Windows_API
+    Dim x As New TheBigOne
+    Dim tbl() As Variant
+    Dim unp() As String
+    Dim unps() As String
+    Dim sql As String
+    Dim error As String
+    Dim orig As Range
+    Dim cms_pl() As String
+    Dim pw As String
+    Dim new_sh As Worksheet
+    Dim ws As Worksheet
+    Dim cp As CustomProperty
+    
+    '------------------------------------selection-------------------------------------------------
+    
+    Set orig = Application.Selection
+    
+    Selection.CurrentRegion.Select
+    
+    Set orig = Application.Selection
+    
+    '--------------------------------test if valid price matrix------------------------------
+    
+    If Selection.Cells.Count = 1 Then
+        MsgBox ("selection is not a table")
+        orig.Select
+        Exit Sub
+    End If
+    
+    tbl = Selection
+    
+    If UBound(tbl, 1) < 4 Then error = "selection is not a valid price matrix"
+    If UBound(tbl, 2) < 2 Then error = "selection is not a valid price matrix"
+    
+    If Not error = "" Then
+        MsgBox (error)
+        Exit Sub
+    End If
+        
+    '-----------------------------unpivot price matrix into new array-----------------------------
+         
+    Dim i As Long
+    Dim j As Long
+    Dim k As Long
+    k = 0
+    ReDim unp(8, (UBound(tbl, 2) - 2) * (UBound(tbl, 1) - 3))
+    For i = 4 To UBound(tbl, 1)
+        For j = 3 To UBound(tbl, 2)
+            k = k + 1
+            'part
+            unp(0, k) = tbl(i, 1)
+            'copy headers down the left
+            unp(1, k) = tbl(1, j) 'size code (row two, column j)
+            unp(2, k) = tbl(i, 2) 'color code/tier (row one, column j)
+            unp(3, k) = tbl(2, j) 'volue break uom (row 3, column j)
+            unp(4, k) = Format(tbl(3, j), "#.00") 'volue break qty (row 4, column j)
+            unp(5, k) = "M" 'pricing unit of measuer
+            unp(6, k) = Format(tbl(i, j), "#.00") 'price (row i, column j)
+            unp(7, k) = i
+            unp(8, k) = j
+        Next j
+    Next i
+    unp(0, 0) = "mold"
+    unp(1, 0) = "sizc"
+    unp(2, 0) = "color"
+    unp(3, 0) = "vbuom"
+    unp(4, 0) = "vbqty"
+    unp(5, 0) = "puom"
+    unp(6, 0) = "price"
+    unp(7, 0) = "orig_row"
+    unp(8, 0) = "orig_col"
+    
+    If Not x.TBLp_TestNumeric(unp, 4) Then
+        MsgBox ("volume break quantity is text")
+        Exit Sub
+    End If
+    
+    If Not x.TBLp_TestNumeric(unp, 6) Then
+        MsgBox ("price is text")
+        Exit Sub
+    End If
+    
+    '-------------------------prepare sql to upload---------------------------------------------------------------
+    
+    sql = x.SQLp_build_sql_values(unp, False, True, Db2, False)
+    sql = "DECLARE GLOBAL TEMPORARY TABLE session.plbuild AS (" & sql & ") WITH DATA"
+    Call wapi.ClipBoard_SetData(sql)
+    
+    If MsgBox(sql, vbOKCancel, "continue with build?") = vbCancel Then Exit Sub
+    
+    login.Show
+    If Not login.proceed Then Exit Sub
+    
+    
+    If Not x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) Then
+        MsgBox ("not able to connect to CMS" & vbCrLf & x.ADOo_errstring)
+        Exit Sub
+    End If
+    
+    If Not x.ADOp_Exec(0, sql) Then
+        MsgBox (x.ADOo_errstring)
+        Call x.ADOp_CloseCon(0)
+        Exit Sub
+    End If
+    
+    '-------------------call price build procedure--------------------------------------------------------
+    
+    cms_pl = x.ADOp_SelectS(0, "CALL rlarp.build_pricelist", True, 25000, True)
+    
+    Call x.ADOp_CloseCon(0)
+    
+    If x.ADOo_errstring <> "" Then
+        MsgBox (x.ADOo_errstring)
+        Exit Sub
+    End If
+    
+    '--------------------------setup an output sheet if necessary-------------------------------
+    
+    For Each ws In Application.Worksheets
+        For Each cp In ws.CustomProperties
+            If cp.Name = "spec_name" And cp.value = "price_list" Then
+                Set new_sh = ws
+                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")
+    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
+    
+    
+    For i = 1 To UBound(cms_pl, 1)
+        Select Case cms_pl(i, 13)
+            Case ""
+                orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor = xlThemeColorAccent6
+            Case "no unit conversion"
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                End If
+            Case "no part number"
+                If orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.ThemeColor <> xlThemeColorAccent6 Then
+                    orig.Worksheet.Cells(orig.row + cms_pl(i, 14) - 1, orig.column + cms_pl(i, 15) - 1).Interior.Color = RGB(255, 255, 161)
+                End If
+        End Select
+    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.Rows(1).Interior.Pattern = xlNone
+    Selection.Rows(2).Interior.Pattern = xlNone
+    Selection.Rows(3).Interior.Pattern = xlNone
+    
+    '----------------------------cleanup-------------------------------------------------------------
+    
+    Set x = Nothing
+    
+End Sub
+
 Sub go_to_price_issue()
 
     Dim ws As Worksheet
@@ -995,6 +1242,7 @@ Sub build_price_upload()
     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
@@ -1011,7 +1259,8 @@ PRICELIST_SHOW:
     pl_d1 = pricelist.tbD1.Text
     pl_d2 = pricelist.tbD2.Text
     pl_d3 = pricelist.tbD3.Text
-    pl_action = "1"
+    pl_action = Mid(pricelist.cbHDR.value, 1, 1)
+    dtl_action = Mid(pricelist.cbDTL.value, 1, 1)
     
     If Len(pricelist.tbCODE) > 5 Then
         MsgBox ("price code must be 5 or less characters")
@@ -1046,7 +1295,7 @@ PRICELIST_SHOW:
             ul(3, j) = pl(7, i)                                                             'price unit
             ul(4, j) = Format(CDbl(pl(6, i)) * CDbl(pl(12, i)) / CDbl(pl(13, i)), "0.00")   'volume break in price uom
             ul(5, j) = Format(pl(8, i), "0.00")                                             'price
-            ul(11, j) = "1"                                                                 'add, update, delete
+            ul(11, j) = dtl_action                                                           'add, update, delete
         End If
     Next i
     
@@ -1065,3 +1314,4 @@ PRICELIST_SHOW:
     
 
 End Sub
+

pricelist.frm

@@ -1,10 +1,10 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist 
    Caption         =   "Price List Name"
-   ClientHeight    =   5115
+   ClientHeight    =   6240
    ClientLeft      =   120
    ClientTop       =   465
-   ClientWidth     =   4110
+   ClientWidth     =   4095
    OleObjectBlob   =   "pricelist.frx":0000
    StartUpPosition =   1  'CenterOwner
 End
@@ -37,8 +37,28 @@ Private Sub bPICK_Click()
 
 End Sub
 
+
+
 Private Sub UserForm_Initialize()
     proceed = False
+    
+    Dim x() As Variant
+    ReDim x(3)
+    x(1) = "1 - New"
+    x(2) = "2 - Replace"
+    x(3) = "3 - Update"
+    
+    Dim dtl() As Variant
+    ReDim dtl(3)
+    dtl(1) = "1 - Add"
+    dtl(2) = "2 - Update"
+    dtl(3) = "3 - Delete"
+    
+    
+    cbHDR.list = x
+    cbDTL.list = dtl
+    
+    
 End Sub
 
 Private Sub UserForm_Terminate()