add 2 subroutines and SQL formatting

This commit is contained in:
Paul Trowbridge 2021-06-16 09:03:23 -04:00
parent 0101b45e8a
commit c80e5296d1
2 changed files with 140 additions and 19 deletions

141
FL.bas
View File

@ -93,7 +93,7 @@ Sub ExtractPNC_CSV()
Dim bal() As String Dim bal() As String
Dim bali As Long Dim bali As Long
Dim sched_loan As String Dim sched_loan As String
Dim P As FileDialog Dim p As FileDialog
Dim i As Long Dim i As Long
Dim j As Long Dim j As Long
Dim m As Long Dim m As Long
@ -109,10 +109,10 @@ Sub ExtractPNC_CSV()
'--------Open file------------- '--------Open file-------------
Set P = Application.FileDialog(msoFileDialogOpen) Set p = Application.FileDialog(msoFileDialogOpen)
P.Show p.Show
'--------Extract text---------- '--------Extract text----------
f = x.FILEp_GetTXT(P.SelectedItems(1), 2000) f = x.FILEp_GetTXT(p.SelectedItems(1), 2000)
'--------resize arrays--------- '--------resize arrays---------
ReDim col(11, UBound(f, 2)) ReDim col(11, UBound(f, 2))
@ -190,11 +190,11 @@ Sub ExtractPNC_CSV()
' sh1.Name = "Collateral" ' sh1.Name = "Collateral"
' sh2.Name = "Balance" ' sh2.Name = "Balance"
If Not x.FILEp_CreateCSV(Mid(P.SelectedItems(1), 1, Len(P.SelectedItems(1)) - 4) & "col.csv", col) Then If Not x.FILEp_CreateCSV(Mid(p.SelectedItems(1), 1, Len(p.SelectedItems(1)) - 4) & "col.csv", col) Then
MsgBox ("error") MsgBox ("error")
End If End If
If Not x.FILEp_CreateCSV(Mid(P.SelectedItems(1), 1, Len(P.SelectedItems(1)) - 4) & "bal.csv", bal) Then If Not x.FILEp_CreateCSV(Mid(p.SelectedItems(1), 1, Len(p.SelectedItems(1)) - 4) & "bal.csv", bal) Then
MsgBox ("error") MsgBox ("error")
End If End If
@ -721,13 +721,13 @@ Attribute pivot_field_format_1dec.VB_ProcData.VB_Invoke_Func = "M\n14"
End Sub End Sub
Sub Write_selection() Sub Write_selection()
Dim P As FileDialog Dim p As FileDialog
'--------Open file------------- '--------Open file-------------
Set P = Application.FileDialog(msoFileDialogSaveAs) Set p = Application.FileDialog(msoFileDialogSaveAs)
P.Show p.Show
Call x.FILEp_CreateTXT(P.SelectedItems(1), x.SHTp_Get(ActiveSheet.Name, Selection.row, Selection.column, False)) Call x.FILEp_CreateTXT(p.SelectedItems(1), x.SHTp_Get(ActiveSheet.Name, Selection.row, Selection.column, False))
End Sub End Sub
@ -1531,3 +1531,124 @@ Sub price_load_pcore()
End Sub End Sub
Sub price_issues()
Dim x As New TheBigOne
Dim ilist() As String
Dim sql As String
If ActiveSheet.Name <> "Issues" Then Exit Sub
ilist = x.SHTp_Get(ActiveSheet.Name, 1, 1, True)
sql = "BEGIN;" & vbCrLf & "DELETE FROM rlarp.issues;" & vbCrLf & "INSERT INTO rlarp.issues" & vbCrLf
sql = sql & x.SQLp_build_sql_values(ilist, True, True, PostgreSQL, False, "S", "S", "S", "S") & ";"
sql = sql & vbCrLf & "END;"
If Not x.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
MsgBox (x.ADOo_errstring)
End If
Call x.ADOp_CloseCon(0)
Set x = Nothing
End Sub
Sub nursery_parse()
Dim tbo As New TheBigOne
Dim sh As Worksheet
Dim a As Long 'header row
Dim i As Long 'last row
Dim j As Long 'starting column
Dim c As Long 'customer column
Dim n As Long 'customer count
Dim x As Long 'max column
Dim b As Long 'ext part iterator
Dim z As Long 'ext all rows iterator
Dim partcol As Long 'part number column
Dim p() As Double 'log
Dim m() As String 'customer name
Dim ext() As String
Dim sql As String
z = 0
partcol = 2
ReDim ext(3, 10000)
ext(0, 0) = "part"
ext(1, 0) = "customer"
ext(2, 0) = "price"
ext(3, 0) = "region"
For Each sh In Application.Worksheets
If InStr(sh.Name, "Price & Volume") > 0 Then
ReDim p(30)
ReDim m(30)
a = 6
'----find max row------------------------------------
i = a + 1
Do Until sh.Cells(i, 2) = "" Or i = 1000
i = i + 1
Loop
i = i - 1
'----find starting column----------------------------
j = 1
Do Until sh.Cells(a, j) = "Order $" Or j = 1000
j = j + 1
Loop
c = 1
'----identity price columns numbers------------------
n = 0
Do Until sh.Cells(a, c + j) = ""
If sh.Cells(a, c + j) = "NEW PRICE" Then
n = n + 1
p(n) = c + j
End If
c = c + 1
Loop
x = c + j
'----get the customer names--------------------------
n = 0
For c = j To x
If sh.Cells(a - 1, c) <> "" Then
n = n + 1
m(n) = sh.Cells(a - 1, c)
End If
Next c
'---resize arrays------
ReDim Preserve p(n)
ReDim Preserve m(n)
'---for each customer loop through all the parts
For n = 1 To UBound(p)
For b = a + 1 To i
z = z + 1
ext(0, z) = sh.Cells(b, partcol)
ext(1, z) = m(n)
ext(2, z) = sh.Cells(b, p(n))
ext(3, z) = sh.Cells(2, 1)
Next b
Next n
Else
'not a price tab
End If
Next sh
ReDim Preserve ext(3, z)
Call tbo.TBLp_FilterSingle(ext, 2, "0", False)
Call tbo.TBLp_FilterSingle(ext, 2, "", False)
sql = tbo.ADOp_BuildInsertSQL(ext, "rlarp.nregional", True, 1, UBound(ext, 2), Array("S", "S", "N", "S"))
sql = "truncate table rlarp.nregional;" & vbCrLf & sql & ";"
If Not tbo.ADOp_Exec(0, sql, 1, True, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then
MsgBox (tbo.ADOo_errstring)
Else
MsgBox ("Uploaded")
End If
End Sub

View File

@ -2400,7 +2400,7 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
Set rx = CreateObject("vbscript.regexp") Set rx = CreateObject("vbscript.regexp")
rx.Global = True rx.Global = True
strip_text = "[^a-zA-Z0-9 \.\-\_\,\#\""]" strip_text = "[^a-zA-Z0-9 \(\)\&\'\.\-\_\,\#\""]"
strip_num = "[^0-9\.]" strip_num = "[^0-9\.]"
strip_date = "[^0-9\/\-\:\.]" strip_date = "[^0-9\/\-\:\.]"
@ -2439,9 +2439,9 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
For i = LBound(tbl, 1) To UBound(tbl, 1) For i = LBound(tbl, 1) To UBound(tbl, 1)
If i > LBound(tbl, 1) Then col_name = col_name & "," If i > LBound(tbl, 1) Then col_name = col_name & ","
If quote_headers Then If quote_headers Then
col_name = col_name & """" & rx.Replace(tbl(i, LBound(tbl, 2)), "") & """" col_name = col_name & """" & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''") & """"
Else Else
col_name = col_name & rx.Replace(tbl(i, LBound(tbl, 2)), "") col_name = col_name & Replace(rx.Replace(tbl(i, LBound(tbl, 2)), ""), "'", "''")
End If End If
Next i Next i
Else Else
@ -2461,7 +2461,7 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
If tbl(j, i) = "" Then If tbl(j, i) = "" Then
rec = rec & "CAST(NULL AS NUMERIC)" rec = rec & "CAST(NULL AS NUMERIC)"
Else Else
rec = rec & rx.Replace(tbl(j, i), "") rec = rec & Replace(rx.Replace(tbl(j, i), ""), "'", "''")
End If End If
Case "S" '-------S = string------------------------------------------ Case "S" '-------S = string------------------------------------------
rx.Pattern = strip_text rx.Pattern = strip_text
@ -2469,9 +2469,9 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
rec = rec & "CAST(NULL AS " & nullText & ")" rec = rec & "CAST(NULL AS " & nullText & ")"
Else Else
If trim Then If trim Then
rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'" rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
Else Else
rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'" rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
End If End If
End If End If
@ -2480,7 +2480,7 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
If LTrim(RTrim(tbl(j, i))) = "" Then If LTrim(RTrim(tbl(j, i))) = "" Then
rec = rec & "CAST(NULL AS DATE)" rec = rec & "CAST(NULL AS DATE)"
Else Else
rec = rec & "CAST('" & rx.Replace(tbl(j, i), "") & "' AS DATE)" rec = rec & "CAST('" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "' AS DATE)"
End If End If
Case Else '-------Assume text------------------------------------------ Case Else '-------Assume text------------------------------------------
rx.Pattern = strip_text rx.Pattern = strip_text
@ -2488,9 +2488,9 @@ Public Function SQLp_build_sql_values(ByRef tbl() As String, trim As Boolean, he
rec = rec & "CAST(NULL AS " & nullText & ")" rec = rec & "CAST(NULL AS " & nullText & ")"
Else Else
If trim Then If trim Then
rec = rec & "'" & LTrim(RTrim(rx.Replace(tbl(j, i), ""))) & "'" rec = rec & "'" & Replace(LTrim(RTrim(rx.Replace(tbl(j, i), ""))), "'", "''") & "'"
Else Else
rec = rec & "'" & rx.Replace(tbl(j, i), "") & "'" rec = rec & "'" & Replace(rx.Replace(tbl(j, i), ""), "'", "''") & "'"
End If End If
End If End If
End Select End Select