diff --git a/FL.bas b/FL.bas index 6fe0f5c..726b752 100644 --- a/FL.bas +++ b/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 + diff --git a/pricelist.frm b/pricelist.frm index ad66d1c..21f0662 100644 --- a/pricelist.frm +++ b/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() diff --git a/pricelist.frx b/pricelist.frx index 34e97e2..a36285e 100644 Binary files a/pricelist.frx and b/pricelist.frx differ