update price list to just pull description columns
This commit is contained in:
pt
parent
0143a891bb
commit
605a1e95b0
730
FL.bas
730
FL.bas
@ -820,392 +820,6 @@ Sub extract_price_matrix()
|
|||||||
|
|
||||||
'------------------------------------setup-------------------------------------------------
|
'------------------------------------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) - 1) * (UBound(tbl, 1) - 4))
|
|
||||||
For i = 5 To UBound(tbl, 1)
|
|
||||||
For j = 2 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) 'color code/tier (row one, column j)
|
|
||||||
unp(2, k) = tbl(2, j) 'size code (row two, column j)
|
|
||||||
unp(3, k) = tbl(3, j) 'volue break uom (row 3, column j)
|
|
||||||
unp(4, k) = Format(tbl(4, 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
|
|
||||||
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
|
|
||||||
|
|
||||||
For i = 1 To UBound(cms_pl, 1)
|
|
||||||
Select Case cms_pl(i, 13)
|
|
||||||
Case ""
|
|
||||||
Case "no unit conversion"
|
|
||||||
orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(255, 255, 161)
|
|
||||||
Case "no part number"
|
|
||||||
'orig.Worksheet.Cells(orig.row + cms_pl(i, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.Color = RGB(220, 220, 220)
|
|
||||||
End Select
|
|
||||||
Next i
|
|
||||||
|
|
||||||
'----------------------------cleanup-------------------------------------------------------------
|
|
||||||
|
|
||||||
Set x = Nothing
|
|
||||||
|
|
||||||
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, 13) - 1, orig.column + cms_pl(i, 14) - 1).Interior.ThemeColor = xlThemeColorAccent6
|
|
||||||
Case "no unit 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 "no part number"
|
|
||||||
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
|
|
||||||
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 extract_price_matrix_r2()
|
|
||||||
|
|
||||||
'------------------------------------setup-------------------------------------------------
|
|
||||||
|
|
||||||
Dim wapi As New Windows_API
|
Dim wapi As New Windows_API
|
||||||
Dim x As New TheBigOne
|
Dim x As New TheBigOne
|
||||||
Dim tbl() As Variant
|
Dim tbl() As Variant
|
||||||
@ -1419,6 +1033,227 @@ Sub extract_price_matrix_r2()
|
|||||||
ini.Select
|
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
|
End Sub
|
||||||
|
|
||||||
Sub go_to_price_issue()
|
Sub go_to_price_issue()
|
||||||
@ -1469,122 +1304,8 @@ Sub go_to_price_issue()
|
|||||||
|
|
||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
Sub build_price_upload()
|
|
||||||
|
|
||||||
Dim x As New TheBigOne
|
Sub build_price_upload_suff()
|
||||||
Dim pl() As String
|
|
||||||
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
|
|
||||||
|
|
||||||
pl = x.SHTp_GetString(Selection)
|
|
||||||
ReDim ul(11, UBound(pl, 2))
|
|
||||||
|
|
||||||
PRICELIST_SHOW:
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
If Not pricelist.cbInactive Then
|
|
||||||
Call x.TBLp_FilterSingle(pl, 11, "I", False)
|
|
||||||
End If
|
|
||||||
|
|
||||||
If Not pricelist.cbNonStocked Then
|
|
||||||
Call x.TBLp_FilterSingle(pl, 10, "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, Db2, False)
|
|
||||||
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
|
|
||||||
If Not FL.x.ADOp_Exec(0, ulsql, 1, True, ISeries, "S7830956", False, login.tbU.Text, login.tbP.Text) 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(12, i) <> "" And pl(7, i) <> "" And pl(8, i) <> "" Then
|
|
||||||
j = j + 1
|
|
||||||
ul(0, j) = "DTL" 'DTL
|
|
||||||
ul(1, j) = pl_code 'Price list code
|
|
||||||
ul(2, j) = pl(8, i) 'part number
|
|
||||||
ul(3, j) = pl(6, i) 'price unit
|
|
||||||
ul(4, j) = Format(CDbl(pl(5, i)) * CDbl(pl(11, i)) / CDbl(pl(12, i)), "0.00") 'volume break in price uom
|
|
||||||
ul(5, j) = Format(pl(7, i), "0.00") 'price
|
|
||||||
ul(11, j) = pl(17, i) '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 build_price_upload_r2()
|
|
||||||
|
|
||||||
Dim x As New TheBigOne
|
Dim x As New TheBigOne
|
||||||
Dim pl() As String
|
Dim pl() As String
|
||||||
@ -1628,10 +1349,14 @@ PRICELIST_SHOW:
|
|||||||
GoTo PRICELIST_SHOW
|
GoTo PRICELIST_SHOW
|
||||||
End If
|
End If
|
||||||
|
|
||||||
|
'--------------remove any lines with errors-------------
|
||||||
If Not pricelist.cbInactive Then
|
If Not pricelist.cbInactive Then
|
||||||
Call x.TBLp_FilterSingle(pl, 11, "I", False)
|
Call x.TBLp_FilterSingle(pl, 16, "", True)
|
||||||
End If
|
End If
|
||||||
|
|
||||||
|
'--------------remove empty price lines-----------------
|
||||||
|
Call x.TBLp_FilterSingle(pl, 13, "", False)
|
||||||
|
|
||||||
If Not pricelist.cbNonStocked Then
|
If Not pricelist.cbNonStocked Then
|
||||||
Call x.TBLp_FilterSingle(pl, 8, "A", True)
|
Call x.TBLp_FilterSingle(pl, 8, "A", True)
|
||||||
End If
|
End If
|
||||||
@ -1707,3 +1432,4 @@ PRICELIST_SHOW:
|
|||||||
|
|
||||||
|
|
||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
|
|||||||
101
pricelist.frm
101
pricelist.frm
@ -1,10 +1,10 @@
|
|||||||
VERSION 5.00
|
VERSION 5.00
|
||||||
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist
|
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} pricelist
|
||||||
Caption = "Price List Name"
|
Caption = "Price List Name"
|
||||||
ClientHeight = 7680
|
ClientHeight = 7995
|
||||||
ClientLeft = 120
|
ClientLeft = 120
|
||||||
ClientTop = 465
|
ClientTop = 465
|
||||||
ClientWidth = 8895.001
|
ClientWidth = 11865
|
||||||
OleObjectBlob = "pricelist.frx":0000
|
OleObjectBlob = "pricelist.frx":0000
|
||||||
StartUpPosition = 1 'CenterOwner
|
StartUpPosition = 1 'CenterOwner
|
||||||
End
|
End
|
||||||
@ -48,15 +48,19 @@ Private Sub bPICK_Click()
|
|||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
|
|
||||||
|
Private Sub cbInactive_Click()
|
||||||
|
|
||||||
|
End Sub
|
||||||
|
|
||||||
Private Sub cbLIST_Change()
|
Private Sub cbLIST_Change()
|
||||||
|
|
||||||
Dim plc() As String
|
Dim plc() As String
|
||||||
plc = pl
|
plc = pl
|
||||||
Call FL.x.TBLp_FilterSingle(plc, 0, cbLIST.value, True)
|
Call FL.x.TBLp_FilterSingle(plc, 0, cbLIST.value, True)
|
||||||
If UBound(plc, 2) = 0 Then Exit Sub
|
If UBound(plc, 2) = 0 Then Exit Sub
|
||||||
Me.tbD1 = plc(5, 1)
|
Me.tbD1 = plc(1, 1)
|
||||||
'Me.tbD2 = plc(12, 1)
|
Me.tbD2 = plc(2, 1)
|
||||||
'Me.tbD3 = plc(13, 1)
|
Me.tbD3 = plc(3, 1)
|
||||||
|
|
||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
@ -76,7 +80,66 @@ Private Sub lbLIST_Click()
|
|||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
Private Sub UserForm_Initialize()
|
Private Sub UserForm_Initialize()
|
||||||
|
|
||||||
|
|
||||||
proceed = False
|
proceed = False
|
||||||
|
Dim x() As Variant
|
||||||
|
Dim i As Long
|
||||||
|
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
|
||||||
|
|
||||||
|
' If login.tbP = "" Then
|
||||||
|
' login.Show
|
||||||
|
' If Not login.proceed Then Exit Sub
|
||||||
|
' If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then
|
||||||
|
' MsgBox (FL.x.ADOo_errstring)
|
||||||
|
' Exit Sub
|
||||||
|
' End If
|
||||||
|
' End If
|
||||||
|
|
||||||
|
If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@042") Then
|
||||||
|
MsgBox (FL.x.ADOo_errstring)
|
||||||
|
Exit Sub
|
||||||
|
End If
|
||||||
|
|
||||||
|
pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1,d2,d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True)
|
||||||
|
Call FL.x.ADOp_CloseCon(1)
|
||||||
|
ReDim plv(1 To UBound(pl, 2))
|
||||||
|
For i = 1 To UBound(pl, 2)
|
||||||
|
plv(i) = pl(0, i)
|
||||||
|
Next i
|
||||||
|
|
||||||
|
plfv = FL.x.TBLp_StringToVar(FL.x.TBLp_Transpose(pl))
|
||||||
|
|
||||||
|
cbLIST.list = plv
|
||||||
|
lbLIST.list = plfv
|
||||||
|
|
||||||
|
'lbHEAD.ColumnCount = lbHist.ColumnCount
|
||||||
|
'lbHEAD.ColumnWidths = lbHist.ColumnWidths
|
||||||
|
|
||||||
|
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "descr1", "descr2", "descr3")
|
||||||
|
|
||||||
|
|
||||||
|
End Sub
|
||||||
|
|
||||||
|
Private Sub UserForm_Terminate()
|
||||||
|
proceed = False
|
||||||
|
End Sub
|
||||||
|
|
||||||
|
Sub load_lists()
|
||||||
|
|
||||||
Dim x() As Variant
|
Dim x() As Variant
|
||||||
Dim i As Long
|
Dim i As Long
|
||||||
@ -96,17 +159,22 @@ Private Sub UserForm_Initialize()
|
|||||||
cbHDR.list = x
|
cbHDR.list = x
|
||||||
cbDTL.list = dtl
|
cbDTL.list = dtl
|
||||||
|
|
||||||
If login.tbP = "" Then
|
' If login.tbP = "" Then
|
||||||
login.Show
|
' login.Show
|
||||||
If Not login.proceed Then Exit Sub
|
' If Not login.proceed Then Exit Sub
|
||||||
If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, login.tbU, login.tbP) Then
|
' If Not FL.x.ADOp_OpenCon(0, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@041") Then
|
||||||
|
' MsgBox (FL.x.ADOo_errstring)
|
||||||
|
' Exit Sub
|
||||||
|
' End If
|
||||||
|
' End If
|
||||||
|
|
||||||
|
If Not FL.x.ADOp_OpenCon(1, ISeries, "S7830956", False, "PTROWBRIDG", "QQQX53@042") Then
|
||||||
MsgBox (FL.x.ADOo_errstring)
|
MsgBox (FL.x.ADOo_errstring)
|
||||||
Exit Sub
|
Exit Sub
|
||||||
End If
|
End If
|
||||||
End If
|
|
||||||
|
|
||||||
pl = FL.x.ADOp_SelectS(0, "SELECT plcode, func, basis, tier, currency, d1 FROM RLARP.PLM p ORDER BY func, tier", True, 1000, True)
|
pl = FL.x.ADOp_SelectS(1, "SELECT plcode, d1, d2, d3 FROM RLARP.PLM p ORDER BY plcode", True, 1000, True)
|
||||||
Call FL.x.ADOp_CloseCon(0)
|
Call FL.x.ADOp_CloseCon(1)
|
||||||
ReDim plv(1 To UBound(pl, 2))
|
ReDim plv(1 To UBound(pl, 2))
|
||||||
For i = 1 To UBound(pl, 2)
|
For i = 1 To UBound(pl, 2)
|
||||||
plv(i) = pl(0, i)
|
plv(i) = pl(0, i)
|
||||||
@ -120,13 +188,6 @@ Private Sub UserForm_Initialize()
|
|||||||
'lbHEAD.ColumnCount = lbHist.ColumnCount
|
'lbHEAD.ColumnCount = lbHist.ColumnCount
|
||||||
'lbHEAD.ColumnWidths = lbHist.ColumnWidths
|
'lbHEAD.ColumnWidths = lbHist.ColumnWidths
|
||||||
|
|
||||||
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "func", "basis", "tier", "currency", "d1")
|
Call FL.x.frmListBoxHeader(lbHEAD, lbLIST, "plcode", "d1", "d2", "d3")
|
||||||
|
|
||||||
|
|
||||||
End Sub
|
End Sub
|
||||||
|
|
||||||
Private Sub UserForm_Terminate()
|
|
||||||
proceed = False
|
|
||||||
End Sub
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
BIN
pricelist.frx
BIN
pricelist.frx
Binary file not shown.
Loading…
Reference in New Issue
Block a user