From b1c21d57ea4ec99745c34a1fd4018d5881f718ad Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Thu, 7 Apr 2022 12:39:00 -0400 Subject: [PATCH] work on core price list --- FL.bas | 5 +- PriceLists.bas | 153 ++++++++++++++++++------------------------------- TheBigOne.cls | 49 +++++++++++++++- 3 files changed, 108 insertions(+), 99 deletions(-) diff --git a/FL.bas b/FL.bas index aea2036..db8ccd4 100644 --- a/FL.bas +++ b/FL.bas @@ -1578,7 +1578,7 @@ Sub pricegroup_upload() If Not x.ADOp_Exec(0, sql, 1, True, ADOinterface.SqlServer, "usmidsql01", True) Then MsgBox (x.ADOo_errstring) Else - MsgBox ("Upload Complete") + 'MsgBox ("Upload Complete") End If Call x.ADOp_CloseCon(0) @@ -1587,6 +1587,7 @@ Sub pricegroup_upload() Call pricegroup_upload_db2 + MsgBox ("Upload Complete") End Sub @@ -1637,7 +1638,7 @@ Sub pricegroup_upload_db2() If i + inc > UBound(ul, 2) Then inc = UBound(ul, 2) - i Loop - MsgBox ("Upload Complete") + 'MsgBox ("Upload Complete") Call x.ADOp_CloseCon(0) diff --git a/PriceLists.bas b/PriceLists.bas index 2402ab4..8430c07 100644 --- a/PriceLists.bas +++ b/PriceLists.bas @@ -1,7 +1,7 @@ Attribute VB_Name = "PriceLists" Option Explicit -Sub extract_price_matrix_suff() +Sub test_full20() '------------------------------------setup------------------------------------------------- @@ -141,13 +141,41 @@ Sub extract_price_matrix_suff() 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 - '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 @@ -174,118 +202,51 @@ End Sub Sub price_load_plcore() 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 - Dim dcol() As Integer 'columns to be deleted - Dim typeflag() As String 'array of column types + 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----------- - 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 - End If - Next i + load = unpivot_current_sheet(plist, pcol) '------if no columns are labeled plist then exit------------------------------ - If pcount = 0 Then Exit Sub - ReDim Preserve pcol(pcount) - ReDim typeflag(9) + If UBound(pcol) = 0 Then Exit Sub - If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then - MsgBox (Err.Description) + '------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, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S", "N", "N") & ";" + + If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU, login.tbP, "Port=5030;Database=ubm") Then + MsgBox (x.ADOo_errstring) Exit Sub End If - '------prepare upload for each price list------------------------------------- - - typeflag(0) = "S" - typeflag(1) = "S" - typeflag(2) = "S" - typeflag(3) = "S" - typeflag(4) = "S" - typeflag(5) = "S" - typeflag(6) = "S" - typeflag(7) = "N" - typeflag(8) = "N" - typeflag(9) = "S" - - For pcount = 1 To UBound(pcol) - '----since there are 3 price columns, those will need transformed to 3 price rows per each original----- - ReDim load(9, UBound(big, 2) * 3) - '----set headers----- - load(0, 0) = "stlc" - load(1, 0) = "coltier" - load(2, 0) = "branding" - load(3, 0) = "accs" - load(4, 0) = "suff" - load(5, 0) = "uomp" - load(6, 0) = "vol_uom" - load(7, 0) = "vol_qty" - load(8, 0) = "vol_price" - load(9, 0) = "listcode" - '-----populate------------ - m = 1 - 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) - m = m + 1 - Next k - Next i - '------build insert statement for target price list----- - sql = "BEGIN;" - sql = sql & vbCrLf & "DELETE FROM rlarp.plcore WHERE listcode = '" & load(9, 1) & "';" - sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" - sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "S", "N", "N", "S") & ";" - sql = sql & vbCrLf & "COMMIT;" - '------do the insert------------------------------------ - If Not x.ADOp_Exec(0, sql) Then - MsgBox (x.ADOo_errstring) - Exit Sub - End If - Next pcount + If Not x.ADOp_Exec(1, sql, 1, True, ADOinterface.SqlServer, "mid-sql02", True) Then + MsgBox (x.ADOo_errstring) + Exit Sub + End If Call x.ADOp_CloseCon(0) + Call x.ADOp_CloseCon(1) End Sub @@ -293,7 +254,7 @@ End Sub -Sub build_price_upload_suff() +Sub build_upload() Dim x As New TheBigOne Dim pl() As String diff --git a/TheBigOne.cls b/TheBigOne.cls index ef28e28..b4df16c 100644 --- a/TheBigOne.cls +++ b/TheBigOne.cls @@ -72,6 +72,53 @@ Public Function TBLp_Aggregate(ByRef tbl() As String, ByRef needsort As Boolean, End Function +Public Function TBLp_Group(ByRef tbl() As String, ByRef headers As Boolean, ParamArray cols()) As String() + +On Error GoTo errh + Dim i As Long 'indexes primary row + Dim j As Long 'indexes secondary chaecker row + Dim k As Integer 'used to start at 0 or 1 + Dim m As Long 'used to aggregate on sequencing lines (i and j aggregate to m line) then shorten array to m length - 1 + + k = 0 + If headers Then k = 1 + m = k + For i = k To UBound(tbl, 2) + If i = UBound(tbl, 2) Then + i = i + End If + j = i + 1 + Do + If j > UBound(tbl, 2) Then Exit Do + If ROWe_MatchesFlag(tbl, i, j, gflds) Then + Call ROWp_Aggregate2Rows(tbl, i, j, sflds) + Else + Exit Do + End If + j = j + 1 + If j > UBound(tbl, 2) Then + Exit Do + End If + Loop + Call ROWp_Copy(tbl, i, m) + m = m + 1 + i = j - 1 + Next i + + ReDim Preserve tbl(UBound(tbl, 1), m - 1) + +errh: + If Err.Number <> 0 Then + Me.ADOo_errstring = Err.Description + TBLp_Roll = False + Exit Function + End If + + TBLp_Roll = True + + +End Function + Function TBLp_BubbleSortAsc(ByRef tbl() As String, ByRef sortflds() As Integer, ByRef typeflds() As String, ByRef headers As Boolean) As Boolean @@ -1843,7 +1890,7 @@ Public Function ADOp_Exec(ByRef con As Integer, ByVal sql As String, Optional Ap GoTo conerr End If End If - + ADOo_con(con).CommandTimeout = 600 Call ADOo_con(con).Execute(sql) ADOp_Exec = True Exit Function