From 414c044fc08a263fef85dcb753067a3dad7fddc0 Mon Sep 17 00:00:00 2001 From: Paul Trowbridge Date: Fri, 5 May 2023 12:57:57 -0400 Subject: [PATCH] updates --- FL.bas | 251 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 240 insertions(+), 11 deletions(-) diff --git a/FL.bas b/FL.bas index e8301e5..ddfd8c3 100644 --- a/FL.bas +++ b/FL.bas @@ -241,9 +241,9 @@ Sub GrabBorrowHist() End Sub -Function fn_coln_colchar(colnum As Long) As String +Function fn_coln_colchar(colNum As Long) As String - fn_coln_colchar = colnum / 26 + fn_coln_colchar = colNum / 26 End Function @@ -561,7 +561,7 @@ Sub sql_from_range_pg_noqh() Dim wapi As New Windows_API Dim r() As String Selection.CurrentRegion.Select - Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, False, "S", "S", "S", "S", "A")) + Call wapi.ClipBoard_SetData(x.SQLp_build_sql_values(x.ARRAYp_get_range_string(Selection), True, True, PostgreSQL, False, False)) End Sub @@ -1323,7 +1323,7 @@ Sub price_load_pcore() '-------identify the active sheet and load the contents to an array----------- Set sh = ActiveSheet - big = x.SHTp_Get(sh.Name, 3, 1, True) + big = x.SHTp_Get(sh.Name, 1, 1, True) '------iterate through the column headers to identify the price lists--------- @@ -1341,7 +1341,7 @@ Sub price_load_pcore() ReDim Preserve pcol(pcount) ReDim typeflag(9) - If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "usmidlnx01", False, "ptrowbridge", "qqqx53!030", "Port=5030;Database=ubm") Then + If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then MsgBox (Err.Description) Exit Sub End If @@ -1380,16 +1380,16 @@ Sub price_load_pcore() load(3, i) = big(3, i) load(4, i) = big(4, i) load(5, i) = big(5, i) - load(6, i) = Format(big(pcol(pcount) - 3, i), "####0.00") + load(6, i) = big(6, i) load(7, i) = Format(big(pcol(pcount) - 2, i), "####0.00") load(8, i) = Format(big(pcol(pcount) - 1, i), "####0.00") load(9, i) = big(pcol(pcount) - 0, i) Next i '------build insert statement for target price list----- sql = "BEGIN;" - sql = sql & vbCrLf & "DELETE FROM rlarp.pcore WHERE plist = '" & load(9, 1) & "';" - sql = sql & vbCrLf & "INSERT INTO rlarp.pcore" - sql = sql & vbCrLf & x.SQLp_build_sql_values(load, True, True, PostgreSQL, False, "S", "S", "S", "S", "S", "S", "N", "N", "N", "S") & ";" + sql = sql & vbCrLf & "DELETE FROM rlarp.plcore WHERE plist = '" & load(9, 1) & "';" + sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" + sql = sql & vbCrLf & x.SQLp_build_sql_values(big, 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 @@ -1403,6 +1403,105 @@ Sub price_load_pcore() End Sub +Sub price_load_pcore_one() + + Dim x As New TheBigOne 'function library + Dim sh As Worksheet 'target worksheet + Dim big() As String 'all price lists in one array + 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 i As Long + Dim j As Long + Dim sql As String + + '-------identify the active sheet and load the contents to an array----------- + + Set sh = ActiveSheet + big = x.SHTp_Get(sh.Name, 1, 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) = "listcode" 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 + ReDim Preserve pcol(pcount) + ReDim typeflag(9) + + If Not x.ADOp_OpenCon(0, PostgreSQLODBC, "10.56.60.254", False, "ptrowbridge", "qqqx53!030", "Port=5432;Database=ubm") Then + MsgBox (Err.Description) + 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) = "N" + typeflag(7) = "N" + typeflag(8) = "N" + typeflag(9) = "S" + + For pcount = 1 To UBound(pcol) + ReDim load(9, UBound(big, 2)) + '----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) = "pckg" +' load(6, 0) = "pack" +' load(7, 0) = "mp" +' load(8, 0) = "bulk" +' load(9, 0) = "plist" + '-----populate------------ +' For i = 1 To UBound(big, 2) +' load(0, i) = big(0, i) +' load(1, i) = big(1, i) +' load(2, i) = big(2, i) +' load(3, i) = big(3, i) +' load(4, i) = big(4, i) +' load(5, i) = big(5, i) +' load(6, i) = big(6, i) +' load(7, i) = Format(big(pcol(pcount) - 2, i), "####0.00") +' load(8, i) = Format(big(pcol(pcount) - 1, i), "####0.00") +' load(9, i) = big(pcol(pcount) - 0, i) +' Next i + '------build insert statement for target price list----- + sql = "BEGIN;" + sql = sql & vbCrLf & "DELETE FROM rlarp.plcore WHERE listcode= '" & big(9, 1) & "';" + sql = sql & vbCrLf & "INSERT INTO rlarp.plcore" + sql = sql & vbCrLf & x.SQLp_build_sql_values(big, True, True, PostgreSQL, False, True, "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) + + +End Sub + + Sub price_issues() Dim x As New TheBigOne @@ -1660,6 +1759,138 @@ Sub clear_page_breaks() End Sub +Sub MergeSameCellsInColumn() + + Dim ws As Worksheet + Dim rng As Range + Dim cell As Range + Dim firstRow As Long + Dim lastRow As Long + Dim colNum As Long + Dim startMerge As Range + Dim endMerge As Range + + ' Set the worksheet where you want to perform the operation + Set ws = ActiveSheet + + ' Define the column number to check for duplicates (A = 1, B = 2, etc.) + colNum = Selection.column + + ' Define the range of rows to work on (you can customize this as needed) + firstRow = Selection.row + lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row + + ' Set the range of cells in the specified column to process + Set rng = ws.Range(ws.Cells(firstRow, colNum), ws.Cells(lastRow, colNum)) + + Application.DisplayAlerts = False + Application.ScreenUpdating = False + + Set startMerge = Nothing + + For Each cell In rng + If startMerge Is Nothing Then + Set startMerge = cell + ElseIf cell.value <> startMerge.value Then + Set endMerge = cell.Offset(-1, 0) + If startMerge.row <> endMerge.row Then + ws.Range(startMerge, endMerge).merge + End If + Set startMerge = cell + End If + Next cell + + If cell Is Nothing Then Set cell = ws.Cells(ws.Rows.Count, colNum).End(xlUp) + + ' Check for the last group of same values + If startMerge.row <> cell.row Then + ws.Range(startMerge, cell).merge + End If + + Application.DisplayAlerts = True + Application.ScreenUpdating = True + +End Sub + +Sub merge_block(column_num As Long, row_num As Long) + + Dim ws As Worksheet + Dim rng As Range + Dim cell As Range + Dim firstRow As Long + Dim lastRow As Long + Dim colNum As Long + Dim startMerge As Range + Dim endMerge As Range + + ' Set the worksheet where you want to perform the operation + Set ws = ActiveSheet + + ' Define the column number to check for duplicates (A = 1, B = 2, etc.) + colNum = column_num + ' Define the range of rows to work on (you can customize this as needed) + firstRow = row_num + lastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).row + + ' Set the range of cells in the specified column to process + Set rng = ws.Range(ws.Cells(firstRow, colNum), ws.Cells(lastRow, colNum)) + + Application.DisplayAlerts = False + Application.ScreenUpdating = False + + Set startMerge = Nothing + + For Each cell In rng + If startMerge Is Nothing Then + Set startMerge = cell + ElseIf cell.value <> startMerge.value Then + Set endMerge = cell.Offset(-1, 0) + If startMerge.row <> endMerge.row Then + ws.Range(startMerge, endMerge).merge + End If + Set startMerge = cell + End If + Next cell + + If cell Is Nothing Then Set cell = ws.Cells(ws.Rows.Count, colNum).End(xlUp) + + ' Check for the last group of same values + If startMerge.row <> cell.row Then + ws.Range(startMerge, cell).merge + End If + + Application.DisplayAlerts = True + Application.ScreenUpdating = True + +End Sub + +Sub merge_first_2_col_row3() + + Call FL.merge_block(1, 3) + Call FL.merge_block(2, 3) + With ActiveSheet.Range("A3:B10000").Borders + .LineStyle = xlContinuous + .Weight = xlThin + .ColorIndex = xlAutomatic + End With + + +End Sub + +Sub unmerge_first2() + + ActiveSheet.Range("A:B").MergeCells = False + ActiveSheet.Range("A:B").Borders(xlDiagonalDown).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlDiagonalUp).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlEdgeLeft).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlEdgeTop).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlEdgeBottom).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlEdgeRight).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlInsideVertical).LineStyle = xlNone + ActiveSheet.Range("A:B").Borders(xlInsideHorizontal).LineStyle = xlNone + +End Sub + Sub load_ffterr() Dim x As New TheBigOne @@ -1837,5 +2068,3 @@ Sub load_index() End Sub - -