move colors to columns, and update the highlighting
This commit is contained in:
parent
64c7be2587
commit
17b974a940
256
FL.bas
256
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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()
|
||||
|
|
|
|||
BIN
pricelist.frx
BIN
pricelist.frx
Binary file not shown.
Loading…
Reference in New Issue