work on core price list

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)
     

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 plist() As String
-    Dim dcol() As Integer       'columns to be deleted
-    Dim typeflag() As String    'array of column types
     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
+    load = unpivot_current_sheet(plist, pcol)
-    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
     
     '------if no columns are labeled plist then exit------------------------------
     
-    If pcount = 0 Then Exit Sub
+    If UBound(pcol) = 0 Then Exit Sub
-    ReDim Preserve pcol(pcount)
-    ReDim typeflag(9)
     
-    If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
+    '------clear out overlapping price lists--------------------------------------
-        MsgBox (Err.Description)
+    
+    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-------------------------------------
+    If Not x.ADOp_Exec(1, sql, 1, True, ADOinterface.SqlServer, "mid-sql02", True) Then
-    
+        MsgBox (x.ADOo_errstring)
-    typeflag(0) = "S"
+        Exit Sub
-    typeflag(1) = "S"
+    End If
-    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
     
     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

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