add tabs per segment if selected
This commit is contained in:
parent
e377d8287b
commit
7bc46ca5d9
297
PriceLists.bas
297
PriceLists.bas
|
|
@ -476,21 +476,20 @@ Sub build_customer_files()
|
|||
|
||||
Dim x As New TheBigOne
|
||||
Dim pl() As String
|
||||
Dim pln() As String
|
||||
Dim plf() As String
|
||||
Dim fc() As String
|
||||
Dim nwb As Workbook
|
||||
Dim fcwb As Workbook
|
||||
Dim nws As Worksheet
|
||||
Dim nnws As Worksheet
|
||||
Dim nfws As Worksheet
|
||||
Dim fcws As Worksheet
|
||||
Dim filepath As String
|
||||
Dim c As Range
|
||||
Dim i As Long
|
||||
Dim j As Long
|
||||
Dim last As Long
|
||||
Dim lastcol As Long
|
||||
Dim clist() As String
|
||||
Dim curr As String
|
||||
Dim plev As String
|
||||
Dim effdate As Date
|
||||
Dim segment_regex As String
|
||||
|
||||
'----------------------pick price level---------------------------------------------------------------------
|
||||
login.Caption = "PostgreSQL Login"
|
||||
|
|
@ -509,88 +508,184 @@ Sub build_customer_files()
|
|||
effdate = CDate(pricelevel.tbEddDate.text)
|
||||
filepath = pricelevel.tbPATH & "\" & plev
|
||||
|
||||
'---------------------get full code list--------------------------------------------------------------------
|
||||
fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If fc(0, 0) <> "Currency" Then
|
||||
MsgBox (fc(0, 0))
|
||||
Exit Sub
|
||||
If pricelevel.chbFULLCODE Then
|
||||
'---------------------get full code list--------------------------------------------------------------------
|
||||
fc = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_fullcode_cust('" & plev & "', '" & effdate & "'::date)", False, 20000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If fc(0, 0) <> "Currency" Then
|
||||
MsgBox (fc(0, 0))
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
'---------------------create new workbook-------------------------------------------------------------------
|
||||
If UBound(fc, 2) = 0 Then
|
||||
MsgBox ("no full code list data for " & plev)
|
||||
Exit Sub
|
||||
End If
|
||||
Application.ScreenUpdating = False
|
||||
Set fcwb = Application.Workbooks.Add
|
||||
fcwb.Activate
|
||||
Set fcws = fcwb.Sheets(1)
|
||||
fcws.Activate
|
||||
'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric
|
||||
Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14)
|
||||
Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
|
||||
|
||||
'--------------------format full code------------------------------------------------------------------------
|
||||
Application.CutCopyMode = False
|
||||
fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing"
|
||||
fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21"
|
||||
fcws.Cells.Font.Name = "Courier New"
|
||||
fcws.Cells.Font.Size = 10
|
||||
With fcws.Rows(3)
|
||||
.WrapText = True
|
||||
.RowHeight = 40.5
|
||||
End With
|
||||
fcws.Columns("A").ColumnWidth = 9.43
|
||||
fcws.Columns("B").ColumnWidth = 20
|
||||
fcws.Columns("C:D").ColumnWidth = 35
|
||||
fcws.Columns("E").ColumnWidth = 21.5
|
||||
fcws.Columns("F").ColumnWidth = 3.71
|
||||
fcws.Columns("G").ColumnWidth = 9.43
|
||||
fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
|
||||
fcws.Columns("H").ColumnWidth = 7.14
|
||||
fcws.Columns("I:P").ColumnWidth = 14
|
||||
fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
|
||||
fcws.Columns("O").ColumnWidth = 10.57
|
||||
fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
|
||||
Rows("3:3").NumberFormat = "General"
|
||||
fcws.Activate
|
||||
ActiveWindow.DisplayGridlines = False
|
||||
Rows("4:4").Select
|
||||
ActiveWindow.FreezePanes = True
|
||||
fcws.ListObjects("Full Code Listing").ShowAutoFilter = False
|
||||
|
||||
'---------------------logo----------------------------------------------------------------------------------
|
||||
fcws.Rows("1:2").RowHeight = 28.5
|
||||
fcws.Cells(1, 1).Select
|
||||
fcws.Pictures.Insert("https://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select
|
||||
Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
|
||||
Selection.ShapeRange.IncrementLeft 2
|
||||
Selection.ShapeRange.IncrementTop 2
|
||||
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
|
||||
fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY")
|
||||
fcws.Name = "Full Code Listing"
|
||||
fcws.Cells(3, 1).Select
|
||||
End If
|
||||
|
||||
'---------------------create new workbook-------------------------------------------------------------------
|
||||
If UBound(fc, 2) = 0 Then
|
||||
MsgBox ("no full code list data for " & plev)
|
||||
Exit Sub
|
||||
End If
|
||||
Application.ScreenUpdating = False
|
||||
Set fcwb = Application.Workbooks.Add
|
||||
fcwb.Activate
|
||||
Set fcws = fcwb.Sheets(1)
|
||||
fcws.Activate
|
||||
'fcws.Cells.NumberFormat = "@" 'format all cells to text so pasted text values are not cast to numeric
|
||||
Call x.SHTp_Dump(fc, fcws.Name, 1, 1, False, True, 6, 7, 8, 9, 10, 11, 12, 13, 14)
|
||||
Rows("1:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
|
||||
|
||||
'--------------------format full code------------------------------------------------------------------------
|
||||
Application.CutCopyMode = False
|
||||
fcws.ListObjects.Add(xlSrcRange, fcws.Cells(3, 1).CurrentRegion, , xlYes).Name = "Full Code Listing"
|
||||
fcws.ListObjects("Full Code Listing").TableStyle = "TableStyleMedium21"
|
||||
fcws.Cells.Font.Name = "Courier New"
|
||||
fcws.Cells.Font.Size = 10
|
||||
With fcws.Rows(3)
|
||||
.WrapText = True
|
||||
.RowHeight = 40.5
|
||||
End With
|
||||
fcws.Columns("A").ColumnWidth = 9.43
|
||||
fcws.Columns("B").ColumnWidth = 20
|
||||
fcws.Columns("C:D").ColumnWidth = 35
|
||||
fcws.Columns("E").ColumnWidth = 21.5
|
||||
fcws.Columns("F").ColumnWidth = 3.71
|
||||
fcws.Columns("G").ColumnWidth = 9.43
|
||||
fcws.Columns("G").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
|
||||
fcws.Columns("H").ColumnWidth = 7.14
|
||||
fcws.Columns("I:P").ColumnWidth = 14
|
||||
fcws.Columns("I:P").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
|
||||
fcws.Columns("O").ColumnWidth = 10.57
|
||||
fcws.Columns("O").NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
|
||||
Rows("3:3").NumberFormat = "General"
|
||||
fcws.Activate
|
||||
ActiveWindow.DisplayGridlines = False
|
||||
Rows("4:4").Select
|
||||
ActiveWindow.FreezePanes = True
|
||||
fcws.ListObjects("Full Code Listing").ShowAutoFilter = False
|
||||
|
||||
'---------------------logo----------------------------------------------------------------------------------
|
||||
fcws.Rows("1:2").RowHeight = 28.5
|
||||
fcws.Cells(1, 1).Select
|
||||
fcws.Pictures.Insert("https://hc-companies.com/wp-content/themes/hc-companies/images/logo.svg").Select
|
||||
Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
|
||||
Selection.ShapeRange.IncrementLeft 2
|
||||
Selection.ShapeRange.IncrementTop 2
|
||||
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes.Item(1), address:="https://hc-companies.com/"
|
||||
fcws.Cells(1, 4).value = "Distributor Price List - Effective " & Format(effdate, "MM/DD/YYYY")
|
||||
fcws.Name = "Full Code Listing"
|
||||
fcws.Cells(3, 1).Select
|
||||
|
||||
'Application.ScreenUpdating = True
|
||||
'Exit Sub
|
||||
|
||||
'---------------------get price list------------------------------------------------------------------------
|
||||
pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If pl(0, 0) <> "Product" Then
|
||||
MsgBox (pl(0, 0))
|
||||
Exit Sub
|
||||
End If
|
||||
|
||||
'---------------------create new workbook-------------------------------------------------------------------
|
||||
Set nwb = Application.Workbooks.Add
|
||||
nwb.Activate
|
||||
Set nws = nwb.Sheets(1)
|
||||
segment_regex = "G|N|F"
|
||||
|
||||
'---------------------get price list------------------------------------------------------------------------
|
||||
If pricelevel.chbNURSERY Then
|
||||
pln = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "', '^N')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If pln(0, 0) <> "Product" Then
|
||||
MsgBox (pln(0, 0))
|
||||
Exit Sub
|
||||
End If
|
||||
If UBound(pln, 2) > 21 Then
|
||||
segment_regex = "^F|^G"
|
||||
Set nnws = nwb.Sheets.Add(, nws)
|
||||
nnws.Name = "Price List - Nursery"
|
||||
Call paste_pretty(pln, nnws, effdate)
|
||||
End If
|
||||
End If
|
||||
|
||||
If pricelevel.chbFIBER Then
|
||||
plf = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','^F')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If plf(0, 0) <> "Product" Then
|
||||
MsgBox (plf(0, 0))
|
||||
Exit Sub
|
||||
End If
|
||||
If UBound(plf, 2) > 21 Then
|
||||
If segment_regex = "^F|^G" Then
|
||||
segment_regex = "^G"
|
||||
Else
|
||||
segment_regex = "^G|^N"
|
||||
End If
|
||||
Set nfws = nwb.Sheets.Add(, nws)
|
||||
nfws.Name = "Price List - Fiber"
|
||||
Call paste_pretty(plf, nfws, effdate)
|
||||
End If
|
||||
End If
|
||||
|
||||
pl = x.ADOp_SelectS(0, "SELECT * FROM rlarp.plcore_build_pretty('" & plev & "','" & segment_regex & "')", False, 2000, True, PostgreSQLODBC, "usmidlnx01", False, login.tbU.text, login.tbP.text, "Port=5030;Database=ubm")
|
||||
If pl(0, 0) <> "Product" Then
|
||||
MsgBox (pl(0, 0))
|
||||
Exit Sub
|
||||
End If
|
||||
If UBound(pl, 2) > 21 Then
|
||||
nws.Name = "Price list"
|
||||
Call paste_pretty(pl, nws, effdate)
|
||||
Else
|
||||
nws.Delete
|
||||
End If
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
|
||||
'--------------------save file--------------------------------------------------------------------------------
|
||||
'Dim fd As Object
|
||||
'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
|
||||
'fd.Show
|
||||
'If fd.SelectedItems.Count = 0 Then Exit Sub
|
||||
With CreateObject("Scripting.FileSystemObject")
|
||||
If Not .FolderExists(filepath) Then .CreateFolder filepath
|
||||
End With
|
||||
Application.DisplayAlerts = True
|
||||
nwb.Activate
|
||||
|
||||
Dim wb As Workbook
|
||||
For Each wb In Workbooks
|
||||
If wb.Name = "HC Companies Distributor Price List.xlsx" Then
|
||||
If MsgBox("already have a price list open, close it?", vbOKCancel) Then
|
||||
Workbooks("HC Companies Distributor Price List.xlsx").Close
|
||||
Exit For
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next wb
|
||||
|
||||
If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx"
|
||||
|
||||
For Each wb In Workbooks
|
||||
If wb.Name = "HC FullCode List.xlsx" Then
|
||||
If MsgBox("already have a full code list open, close it?", vbOKCancel) Then
|
||||
Workbooks("HC FullCode List.xlsx").Close
|
||||
Exit For
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next wb
|
||||
|
||||
If Not (fcwb Is Nothing) Then
|
||||
If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx"
|
||||
End If
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Sub paste_pretty(ByRef pl() As String, ByRef nws As Worksheet, ByVal effdate As Date)
|
||||
|
||||
Dim c As Range
|
||||
Dim i As Long
|
||||
Dim last As Long
|
||||
Dim lastcol As Long
|
||||
Dim j As Long
|
||||
Dim curr As String
|
||||
|
||||
nws.Activate
|
||||
nws.Cells.NumberFormat = "@"
|
||||
'---------------------format to numeric if selected---------------------------------------------------------
|
||||
If pricelevel.cbNUMERIC Then
|
||||
Call x.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16)
|
||||
Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
|
||||
Call tbo.SHTp_Dump(pl, nws.Name, 1, 1, False, True, 9, 12, 15, 10, 13, 16)
|
||||
nws.Rows("1:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
|
||||
nws.Columns(10).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
|
||||
nws.Columns(13).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
|
||||
nws.Columns(16).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""???_);_(@_)"
|
||||
|
|
@ -602,7 +697,7 @@ Sub build_customer_files()
|
|||
nws.Columns(16).ColumnWidth = 13
|
||||
nws.Rows(5).NumberFormat = "@"
|
||||
Else
|
||||
Call x.SHTp_Dump(pl, nws.Name, 5, 1, False, True)
|
||||
Call tbo.SHTp_Dump(pl, nws.Name, 5, 1, False, True)
|
||||
nws.Columns(10).ColumnWidth = 10.57
|
||||
nws.Columns(13).ColumnWidth = 10.57
|
||||
nws.Columns(16).ColumnWidth = 10.57
|
||||
|
|
@ -729,9 +824,9 @@ Sub build_customer_files()
|
|||
Next i
|
||||
|
||||
'--------------------print header data--------------------------------------------------------------------------
|
||||
pl = x.TBLp_Transpose(pl)
|
||||
Call x.TBLp_FilterSingle(pl, 20, "", False)
|
||||
Call x.TBLp_Group(pl, True, x.ARRAYp_MakeInteger(20))
|
||||
pl = tbo.TBLp_Transpose(pl)
|
||||
Call tbo.TBLp_FilterSingle(pl, 20, "", False)
|
||||
Call tbo.TBLp_Group(pl, True, tbo.ARRAYp_MakeInteger(20))
|
||||
If UBound(pl, 2) > 1 Then
|
||||
'---somehow multiple currencies involved----
|
||||
MsgBox ("multiple currencies")
|
||||
|
|
@ -747,54 +842,14 @@ Sub build_customer_files()
|
|||
End Select
|
||||
End If
|
||||
nws.Cells(2, 3).value = "Distributor Price List (" & curr & ") - Effective " & Format(effdate, "MM/DD/YYYY")
|
||||
nws.Name = "Price List"
|
||||
nws.Cells(5, 1).Select
|
||||
|
||||
Call print_setup(nws, last)
|
||||
|
||||
nws.Columns("R:V").Delete
|
||||
|
||||
Application.ScreenUpdating = True
|
||||
|
||||
'--------------------save file--------------------------------------------------------------------------------
|
||||
'Dim fd As Object
|
||||
'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
|
||||
'fd.Show
|
||||
'If fd.SelectedItems.Count = 0 Then Exit Sub
|
||||
With CreateObject("Scripting.FileSystemObject")
|
||||
If Not .FolderExists(filepath) Then .CreateFolder filepath
|
||||
End With
|
||||
Application.DisplayAlerts = True
|
||||
nwb.Activate
|
||||
|
||||
Dim wb As Workbook
|
||||
For Each wb In Workbooks
|
||||
If wb.Name = "HC Companies Distributor Price List.xlsx" Then
|
||||
If MsgBox("already have a price list open, close it?", vbOKCancel) Then
|
||||
Workbooks("HC Companies Distributor Price List.xlsx").Close
|
||||
Exit For
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next wb
|
||||
|
||||
If pricelevel.tbPATH.text <> "" Then nwb.SaveAs Filename:=filepath & "\HC Companies Distributor Price List.xlsx"
|
||||
|
||||
For Each wb In Workbooks
|
||||
If wb.Name = "HC FullCode List.xlsx" Then
|
||||
If MsgBox("already have a full code list open, close it?", vbOKCancel) Then
|
||||
Workbooks("HC FullCode List.xlsx").Close
|
||||
Exit For
|
||||
Else
|
||||
Exit Sub
|
||||
End If
|
||||
End If
|
||||
Next wb
|
||||
|
||||
If pricelevel.tbPATH.text <> "" Then fcwb.SaveAs Filename:=filepath & "\HC FullCode List.xlsx"
|
||||
|
||||
|
||||
|
||||
|
||||
End Sub
|
||||
|
||||
Function rrange(ByRef sheet As Worksheet, start_row As Long, end_row As Long, start_col As Long, end_col As Long) As Range
|
||||
|
|
|
|||
BIN
pricelevel.frx
BIN
pricelevel.frx
Binary file not shown.
Loading…
Reference in New Issue