new target price builder
This commit is contained in:
parent
95cc855722
commit
d4b4236f3e
562
TargetGroups.bas
Normal file
562
TargetGroups.bas
Normal file
@ -0,0 +1,562 @@
|
||||
Attribute VB_Name = "TargetGroups"
|
||||
' Declare the API function to read from INI
|
||||
Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" _
|
||||
Alias "GetPrivateProfileStringA" ( _
|
||||
ByVal lpAppName As String, _
|
||||
ByVal lpKeyName As String, _
|
||||
ByVal lpDefault As String, _
|
||||
ByVal lpReturnedString As String, _
|
||||
ByVal nSize As Long, _
|
||||
ByVal lpFileName As String) As Long
|
||||
|
||||
' Helper to read from ini
|
||||
Function ReadINI(section As String, key As String, filepath As String) As String
|
||||
|
||||
Dim buffer As String * 1024
|
||||
Dim length As Long
|
||||
length = GetPrivateProfileString(section, key, "", buffer, Len(buffer), filepath)
|
||||
ReadINI = Left(buffer, length)
|
||||
|
||||
End Function
|
||||
|
||||
|
||||
|
||||
Sub ReadConfig()
|
||||
|
||||
Dim basePath As String
|
||||
Dim folderName As String
|
||||
Dim targetFolder As String
|
||||
Dim configPath As String
|
||||
Dim reviewGroup As String
|
||||
Dim regexPattern As String
|
||||
Dim volumeCode As String
|
||||
Dim statusCode As String
|
||||
Dim fso As Object
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === 1. Get paths from sheets ===
|
||||
basePath = trim(Sheets("env").Range("B1").value)
|
||||
If basePath = "" Then
|
||||
MsgBox "Error: Base path (env!B1) is blank.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
||||
|
||||
folderName = trim(Sheets("combine").Cells(2, 1).value)
|
||||
If folderName = "" Then
|
||||
MsgBox "Error: No folder name in combine!A2.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
targetFolder = basePath & folderName & "\"
|
||||
configPath = targetFolder & "config.ini"
|
||||
|
||||
' === 2. Check that folder exists ===
|
||||
If Not fso.FolderExists(targetFolder) Then
|
||||
MsgBox "Folder not found: " & targetFolder, vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === 3. Check that config.ini exists ===
|
||||
If Not fso.FileExists(configPath) Then
|
||||
MsgBox "config.ini not found in: " & targetFolder, vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === 4. Read values from INI ===
|
||||
reviewGroup = ReadINI("Filter", "ReviewGroup", configPath)
|
||||
regexPattern = ReadINI("Filter", "ProductFamilyRegex", configPath)
|
||||
volumeCode = ReadINI("Filter", "VolumeUOM", configPath)
|
||||
statusCode = ReadINI("Filter", "StatusCode", configPath)
|
||||
|
||||
' === 5. Handle empty values with fallback ===
|
||||
If reviewGroup = "" Then reviewGroup = "(not defined)"
|
||||
If regexPattern = "" Then regexPattern = "(not defined)"
|
||||
If volumeCode = "" Then volumeCode = "GAL"
|
||||
If statusCode = "" Then statusCode = "FALSE"
|
||||
|
||||
' === 6. Write results to Excel cells ===
|
||||
Sheets("combine").Range("A2").value = reviewGroup
|
||||
Sheets("combine").Range("A5").value = regexPattern
|
||||
Sheets("combine").Range("A8").value = volumeCode
|
||||
Sheets("combine").Range("A11").value = statusCode
|
||||
|
||||
' === 7. Load options ===
|
||||
Call LoadOptionsAndCosts
|
||||
Exit Sub
|
||||
|
||||
' === Error handling ===
|
||||
HandleError:
|
||||
MsgBox "Error in LoadConfigINI_ReadOnly: " & Err.Description, vbExclamation
|
||||
End Sub
|
||||
|
||||
Sub WriteConfig()
|
||||
Dim basePath As String
|
||||
Dim folderName As String
|
||||
Dim targetFolder As String
|
||||
Dim configPath As String
|
||||
Dim volumeCode As String
|
||||
Dim statusCode As String
|
||||
Dim fso As Object
|
||||
Dim ts As Object
|
||||
|
||||
' Values to write
|
||||
Dim reviewGroup As String
|
||||
Dim regexPattern As String
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === 1. Get base path from env!B1 ===
|
||||
basePath = trim(Sheets("env").Range("B1").value)
|
||||
If basePath = "" Then
|
||||
MsgBox "Error: Base path in env!B1 is blank.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
||||
|
||||
' === 2. Get folder name from combine!A2 ===
|
||||
folderName = trim(Sheets("combine").Cells(2, 1).value)
|
||||
If folderName = "" Then
|
||||
MsgBox "Error: No folder name in combine!A2.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
targetFolder = basePath & folderName & "\"
|
||||
configPath = targetFolder & "config.ini"
|
||||
|
||||
' === 3. Get config values from Excel ===
|
||||
reviewGroup = folderName
|
||||
regexPattern = trim(Sheets("combine").Cells(5, 1).value)
|
||||
If regexPattern = "" Then regexPattern = ".*" ' default fallback
|
||||
volumeCode = trim(Sheets("combine").Cells(8, 1).value)
|
||||
statusCode = trim(Sheets("combine").Cells(11, 1).value)
|
||||
|
||||
' === 4. Ensure target folder exists ===
|
||||
If Not fso.FolderExists(targetFolder) Then
|
||||
fso.CreateFolder targetFolder
|
||||
End If
|
||||
|
||||
' === 5. Always write (overwrite) config.ini ===
|
||||
Set ts = fso.CreateTextFile(configPath, True, False)
|
||||
ts.WriteLine "[Filter]"
|
||||
ts.WriteLine "ReviewGroup = " & reviewGroup
|
||||
ts.WriteLine "ProductFamilyRegex = " & regexPattern
|
||||
ts.WriteLine "VolumeUOM = " & volumeCode
|
||||
ts.WriteLine "StatusCode = " & statusCode
|
||||
ts.Close
|
||||
|
||||
' === 6. Done silently ===
|
||||
Call ListTargetFolders
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in WriteConfigFromExcel:" & vbCrLf & Err.Description, vbExclamation
|
||||
|
||||
Call ListTargetFolders
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub ListTargetFolders()
|
||||
|
||||
Dim basePath As String
|
||||
Dim fso As Object, folder As Object, subfolder As Object
|
||||
Dim ws As Worksheet
|
||||
Dim i As Long
|
||||
Dim folderListRange As Range
|
||||
|
||||
' Read path from env!B1
|
||||
basePath = Sheets("env").Range("B1").value
|
||||
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
||||
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
If Not fso.FolderExists(basePath) Then
|
||||
MsgBox "Base path not found: " & basePath, vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Set folder = fso.GetFolder(basePath)
|
||||
Set ws = Sheets("env")
|
||||
|
||||
' Clear old list
|
||||
ws.Range("A4:A100").ClearContents
|
||||
i = 4
|
||||
|
||||
' Write folder names
|
||||
For Each subfolder In folder.SubFolders
|
||||
ws.Cells(i, 1).value = subfolder.Name
|
||||
i = i + 1
|
||||
Next
|
||||
|
||||
' Always clear any old named range first
|
||||
On Error Resume Next
|
||||
ThisWorkbook.Names("TargetFolderList").Delete
|
||||
On Error GoTo 0
|
||||
|
||||
' Only create the named range if we found folders
|
||||
If i > 4 Then
|
||||
Set folderListRange = ws.Range("A4").Resize(i - 4)
|
||||
ActiveWorkbook.Names.Add Name:="TargetFolderList", RefersTo:="=" & ws.Name & "!" & folderListRange.address
|
||||
End If
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub LoadOptionsAndCosts()
|
||||
|
||||
Const COL_FOLDER As Long = 1
|
||||
Const ROW_FOLDER As Long = 2
|
||||
Const COL_REGEX As Long = 1
|
||||
Const ROW_REGEX As Long = 5
|
||||
|
||||
Dim ws As Worksheet
|
||||
Dim res() As String
|
||||
Dim onfile() As String
|
||||
Dim csvTable As Variant
|
||||
Dim optionsJSON As String
|
||||
Dim pricegroup As String
|
||||
Dim folder As String
|
||||
Dim sql As String
|
||||
Dim fpath As String
|
||||
Dim i As Long
|
||||
Dim x As New TheBigOne
|
||||
Dim fso As Object
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set ws = ActiveSheet
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === Read mold (regex) and folder ===
|
||||
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
||||
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
||||
|
||||
If pricegroup = "" Then
|
||||
MsgBox "Error: No regex pattern provided in cell A5.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Build the CSV path ===
|
||||
fpath = Sheets("env").Range("B1").value
|
||||
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
||||
fpath = fpath & folder & "\options.csv"
|
||||
|
||||
' === Build optionsJSON ===
|
||||
If fso.FileExists(fpath) Then
|
||||
onfile = x.FILEp_GetCSV(fpath)
|
||||
csvTable = onfile
|
||||
optionsJSON = x.json_from_table(csvTable, "", True)
|
||||
Else
|
||||
optionsJSON = "[]"
|
||||
End If
|
||||
|
||||
' === 1. dump the CSV directly ===
|
||||
ws.Range("P2:ZZ50000").ClearContents
|
||||
If optionsJSON <> "[]" Then
|
||||
onfile = x.TBLp_Transpose(onfile)
|
||||
Call x.SHTp_Dump(onfile, ws.Name, 1, 16, False, True, 2)
|
||||
End If
|
||||
|
||||
' === 2. Get option costs ===
|
||||
sql = "SELECT * FROM rlarp.get_option_costs_priceg('" & Replace(pricegroup, "'", "''") & "') " & _
|
||||
"ORDER BY branding, coltier, uomp;"
|
||||
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
||||
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
||||
ws.Range("C2:N50000").ClearContents
|
||||
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 7, 8, 9, 10, 11)
|
||||
|
||||
Cleanup:
|
||||
On Error Resume Next
|
||||
Call x.ADOp_CloseCon(0)
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in LoadOptionsAndCosts: " & Err.Description, vbExclamation
|
||||
Resume Cleanup
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub WriteTargets()
|
||||
|
||||
' === Constants for easy maintenance ===
|
||||
Const COL_FOLDER As Long = 1
|
||||
Const ROW_FOLDER As Long = 2
|
||||
Const COL_PRICEGROUP As Long = 1
|
||||
Const ROW_PRICEGROUP As Long = 5
|
||||
|
||||
Dim ws As Worksheet
|
||||
Dim x As New TheBigOne
|
||||
Dim wapi As New Windows_API
|
||||
Dim fso As Object
|
||||
Dim opt() As String
|
||||
Dim tar() As String
|
||||
Dim sql() As String
|
||||
Dim sqlt As String
|
||||
Dim targt As String
|
||||
Dim i As Long
|
||||
Dim tbl() As Variant
|
||||
Dim basePath As String
|
||||
Dim folderName As String
|
||||
Dim targetFolder As String
|
||||
Dim optionsPath As String
|
||||
Dim mergeTemplatePath As String
|
||||
Dim mergeOutputPath As String
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Call WriteConfig
|
||||
|
||||
Set ws = ActiveSheet
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === 1. Get base path and folder name from sheets ===
|
||||
basePath = trim(Sheets("env").Cells(1, 2).value)
|
||||
If basePath = "" Then
|
||||
MsgBox "Error: Base path in env!B1 is blank.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
|
||||
|
||||
folderName = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
||||
If folderName = "" Then
|
||||
MsgBox "Error: Folder name in A2 is blank.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
targetFolder = basePath & folderName & "\"
|
||||
|
||||
' === 2. Ensure target folder exists ===
|
||||
If Not fso.FolderExists(targetFolder) Then
|
||||
fso.CreateFolder targetFolder
|
||||
End If
|
||||
|
||||
' === 3. Create options.csv ===
|
||||
opt = x.SHTp_Get(ws.Name, 1, 16, True)
|
||||
optionsPath = targetFolder & "options.csv"
|
||||
If Not x.FILEp_CreateCSV(optionsPath, opt) Then
|
||||
MsgBox "Error: Failed to create options.csv", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in WriteTargets: " & Err.Description, vbExclamation
|
||||
Exit Sub
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
|
||||
Sub BuildPricingPath()
|
||||
|
||||
Const COL_FOLDER As Long = 1
|
||||
Const ROW_FOLDER As Long = 2
|
||||
Const COL_REGEX As Long = 1
|
||||
Const ROW_REGEX As Long = 5
|
||||
|
||||
Dim ws As Worksheet
|
||||
Dim res() As String
|
||||
Dim onfile() As String
|
||||
Dim csvTable As Variant
|
||||
Dim optionsJSON As String
|
||||
Dim pricegroup As String
|
||||
Dim folder As String
|
||||
Dim sql As String
|
||||
Dim fpath As String
|
||||
Dim i As Long
|
||||
Dim x As New TheBigOne
|
||||
Dim fso As Object
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set ws = ActiveSheet
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === Read regex and folder ===
|
||||
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
||||
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
||||
|
||||
If folder = "" Then
|
||||
MsgBox "Error: No folder name in A2.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Build CSV path ===
|
||||
fpath = Sheets("env").Range("B1").value
|
||||
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
||||
fpath = fpath & folder & "\options.csv"
|
||||
|
||||
' === Build options JSON ===
|
||||
If fso.FileExists(fpath) Then
|
||||
onfile = x.FILEp_GetCSV(fpath)
|
||||
csvTable = onfile
|
||||
optionsJSON = x.json_from_table(csvTable, "", True)
|
||||
Else
|
||||
optionsJSON = "[]"
|
||||
End If
|
||||
|
||||
' === 1. Call Postgres NEW FUNCTION ===
|
||||
sql = "SELECT attr, ds, chan, tier, vol, agg FROM pricequote.build_pricing_path(" & _
|
||||
"'" & Replace(optionsJSON, "'", "''") & "') WHERE lastflag"
|
||||
|
||||
res = x.ADOp_SelectS(0, sql, True, 50000, True, PostgreSQLODBC, _
|
||||
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
||||
|
||||
ws.Range("V:ZZ").ClearContents
|
||||
Call x.SHTp_Dump(res, ws.Name, 1, 22, False, True, 5)
|
||||
|
||||
|
||||
Cleanup:
|
||||
On Error Resume Next
|
||||
Call x.ADOp_CloseCon(0)
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in BuildPricingPath: " & Err.Description, vbExclamation
|
||||
Resume Cleanup
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub BuildOptionsAndCosts()
|
||||
|
||||
Const COL_FOLDER As Long = 1
|
||||
Const ROW_FOLDER As Long = 2
|
||||
Const COL_REGEX As Long = 1
|
||||
Const ROW_REGEX As Long = 5
|
||||
|
||||
Dim ws As Worksheet
|
||||
Dim res() As String
|
||||
Dim onfile() As String
|
||||
Dim csvTable As Variant
|
||||
Dim optionsJSON As String
|
||||
Dim pricegroup As String
|
||||
Dim folder As String
|
||||
Dim sql As String
|
||||
Dim fpath As String
|
||||
Dim i As Long
|
||||
Dim x As New TheBigOne
|
||||
Dim fso As Object
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set ws = ActiveSheet
|
||||
Set fso = CreateObject("Scripting.FileSystemObject")
|
||||
|
||||
' === Read mold (regex) and folder ===
|
||||
pricegroup = trim(ws.Cells(ROW_REGEX, COL_REGEX).value)
|
||||
folder = trim(ws.Cells(ROW_FOLDER, COL_FOLDER).value)
|
||||
|
||||
If pricegroup = "" Then
|
||||
MsgBox "Error: No regex pattern provided in cell A5.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Build the CSV path ===
|
||||
fpath = Sheets("env").Range("B1").value
|
||||
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
|
||||
fpath = fpath & folder & "\options.csv"
|
||||
|
||||
' === Build optionsJSON ===
|
||||
If fso.FileExists(fpath) Then
|
||||
onfile = x.FILEp_GetCSV(fpath)
|
||||
csvTable = onfile
|
||||
optionsJSON = x.json_from_table(csvTable, "", True)
|
||||
Else
|
||||
optionsJSON = "[]"
|
||||
End If
|
||||
|
||||
' === 1. Call Postgres for merged options ===
|
||||
sql = "SELECT * FROM rlarp.get_options_merged(" & _
|
||||
"'" & Replace(pricegroup, "'", "''") & "', " & _
|
||||
"'" & Replace(optionsJSON, "'", "''") & "');"
|
||||
|
||||
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
||||
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
||||
ws.Range("P:ZZ").ClearContents
|
||||
Call x.SHTp_Dump(res, ws.Name, ws.Cells(ws.Rows.Count, 16).End(xlUp).row, 16, False, True, 2)
|
||||
|
||||
' === 2. Get option costs ===
|
||||
sql = "SELECT * FROM rlarp.get_option_costs_priceg('" & Replace(pricegroup, "'", "''") & "') " & _
|
||||
"ORDER BY branding, coltier, uomp;"
|
||||
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
||||
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
||||
ws.Range("C:N").ClearContents
|
||||
Call x.SHTp_Dump(res, ws.Name, 1, 3, False, True, 7, 8, 9, 10, 11)
|
||||
|
||||
Cleanup:
|
||||
On Error Resume Next
|
||||
Call x.ADOp_CloseCon(0)
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in LoadOptionsAndCosts: " & Err.Description, vbExclamation
|
||||
Resume Cleanup
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Sub GetProductInfo()
|
||||
|
||||
Const COL_INPUT As Long = 1
|
||||
Const ROW_INPUT As Long = 5
|
||||
|
||||
Dim ws As Worksheet
|
||||
Dim res() As String
|
||||
Dim productCode As String
|
||||
Dim volumeCode As String
|
||||
Dim sql As String
|
||||
Dim x As New TheBigOne
|
||||
Dim qry As Worksheet
|
||||
|
||||
On Error GoTo HandleError
|
||||
|
||||
Set ws = Sheets("combine")
|
||||
Set qry = Sheets("Products")
|
||||
|
||||
' === Read product code from A5 ===
|
||||
productCode = trim(ws.Cells(ROW_INPUT, COL_INPUT).value)
|
||||
volumeCode = trim(ws.Cells(8, 1).value)
|
||||
|
||||
If productCode = "" Then
|
||||
MsgBox "Error: No product code provided in cell A5.", vbExclamation
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
' === Build SQL to call Postgres function ===
|
||||
sql = "SELECT * FROM rlarp.get_product_info(" & _
|
||||
"'" & Replace(productCode, "'", "''") & "', " & _
|
||||
"'" & Replace(volumeCode, "'", "''") & "');"
|
||||
|
||||
' === Call Postgres ===
|
||||
res = x.ADOp_SelectS(0, sql, True, 10000, True, PostgreSQLODBC, _
|
||||
"usmidsap02", False, "report", "report", "Port=5432;Database=ubm")
|
||||
|
||||
' === Clear previous output ===
|
||||
qry.Range("A:ZZ").ClearContents
|
||||
|
||||
' === Dump results starting at column A ===
|
||||
Call x.SHTp_Dump(res, qry.Name, 1, 1, False, True, 4, 5)
|
||||
|
||||
qry.Activate
|
||||
|
||||
Cleanup:
|
||||
On Error Resume Next
|
||||
Call x.ADOp_CloseCon(0)
|
||||
Exit Sub
|
||||
|
||||
HandleError:
|
||||
MsgBox "Error in GetProductInfo: " & Err.Description, vbExclamation
|
||||
Resume Cleanup
|
||||
|
||||
End Sub
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user