pt/VBA
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

minor updates

Browse Source
This commit is contained in:
pt 2020-02-19 23:03:48 -05:00
parent 8e467677c4
commit 1ca398bb8e
6 changed files with 119 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
changes.frm
View File

@ -1,10 +1,10 @@
VERSION 5.00 VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} changes
Caption = "History" Caption = "History"
ClientHeight = 7740 ClientHeight = 7785
ClientLeft = 120 ClientLeft = 120
ClientTop = 465 ClientTop = 465
ClientWidth = 16260 ClientWidth = 17145
OleObjectBlob = "changes.frx":0000 OleObjectBlob = "changes.frx":0000
StartUpPosition = 1 'CenterOwner StartUpPosition = 1 'CenterOwner
End End
@ -23,24 +23,11 @@ End Sub
Private Sub cbUndo_Click() Private Sub cbUndo_Click()
Dim logid As Integer If Not MsgBox("Permanently delete these changes?", vbOKCancel) Then
Dim i As Integer
Dim fail As Boolean
For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then
Call handler.undo_changes(x(i, 6), fail)
If fail Then
MsgBox ("undo did not work")
Exit Sub Exit Sub
End If End If
End If
Next i
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
Me.Hide
Call Me.delete_selected
End Sub End Sub
@ -50,7 +37,7 @@ Private Sub lbHist_Change()
For i = 0 To Me.lbHist.ListCount - 1 For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then If Me.lbHist.Selected(i) Then
Me.tbPrint.value = x(i, 6) Me.tbPrint.value = x(i, 7)
Exit Sub Exit Sub
End If End If
Next i Next i
@ -61,6 +48,20 @@ End Sub
Private Sub lbHist_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 46
If Not MsgBox("Permanently delete these changes?", vbOKCancel) Then
Exit Sub
End If
Call Me.delete_selected
Case 27
Call Me.Hide
End Select
End Sub
Private Sub UserForm_Activate() Private Sub UserForm_Activate()
Dim fail As Boolean Dim fail As Boolean
@ -75,3 +76,31 @@ Private Sub UserForm_Activate()
End Sub End Sub
Sub delete_selected()
Dim logid As Integer
Dim i As Integer
Dim fail As Boolean
Dim proceed As Boolean
If Not MsgBox("Permanently delete these changes?", vbOKCancel) Then
Exit Sub
End If
For i = 0 To Me.lbHist.ListCount - 1
If Me.lbHist.Selected(i) Then
Call handler.undo_changes(x(i, 6), fail)
If fail Then
MsgBox ("undo did not work")
Exit Sub
End If
End If
Next i
Sheets("Orders").PivotTables("PivotTable1").PivotCache.Refresh
Me.lbHist.clear
Me.Hide
End Sub

BIN
changes.frx
View File

Binary file not shown.

9
fpvt.frm
View File

@ -565,6 +565,8 @@ Private Sub UserForm_Activate()
basket(i, 3) = sp("package")("basket")(i)("mix") basket(i, 3) = sp("package")("basket")(i)("mix")
Next i Next i
'-------------load tags-------------------------------
If Not IsNull(sp("package")("tags")) Then If Not IsNull(sp("package")("tags")) Then
ReDim tags(sp("package")("tags").Count - 1, 0) ReDim tags(sp("package")("tags").Count - 1, 0)
For i = 1 To sp("package")("tags").Count For i = 1 To sp("package")("tags").Count
@ -572,8 +574,15 @@ Private Sub UserForm_Activate()
Next i Next i
cbTAG.list = tags cbTAG.list = tags
Sheets("month").cbMTAG.list = tags Sheets("month").cbMTAG.list = tags
cbTAG.ListRows = UBound(tags, 1) + 1
months.cbMTAG.ListRows = UBound(tags, 1) + 1
End If End If
'----------reset spinner buttons----------------------
sbpd.value = 0
sbpp.value = 0
sbpd.value = 0
Call handler.month_tosheet(month, basket) Call handler.month_tosheet(month, basket)
Application.StatusBar = False Application.StatusBar = False

BIN
fpvt.frx
View File

Binary file not shown.

88
months.cls
View File

@ -28,6 +28,7 @@ Private basket_touch As Range
Private showbasket As Boolean Private showbasket As Boolean
Private np As Object 'json dedicated to new part scenario Private np As Object 'json dedicated to new part scenario
Private b() As Variant 'holds basket Private b() As Variant 'holds basket
Private did_load_config As Boolean
@ -89,12 +90,18 @@ Private Sub tbMCOM_Change()
End Sub End Sub
Private Sub Worksheet_Change(ByVal target As Range) Private Sub Worksheet_Change(ByVal Target As Range)
'---this needs checked prior to dumping check becuase % increase spinners are flagged as dumps
If Not did_load_config Then
Call handler.load_config
did_load_config = True
End If
If Not dumping Then If Not dumping Then
If Not Intersect(target, Range("A1:R18")) Is Nothing Then If Not Intersect(Target, Range("A1:R18")) Is Nothing Then
If target.Columns.Count > 1 Then If Target.Columns.Count > 1 Then
MsgBox ("you can only change one column at a time - your change will be undone") MsgBox ("you can only change one column at a time - your change will be undone")
dumping = True dumping = True
Application.Undo Application.Undo
@ -103,15 +110,15 @@ Private Sub Worksheet_Change(ByVal target As Range)
End If End If
End If End If
If Not Intersect(target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj If Not Intersect(Target, Range("E6:E17")) Is Nothing Then Call Me.mvp_adj
If Not Intersect(target, Range("F6:F17")) Is Nothing Then Call Me.mvp_set If Not Intersect(Target, Range("F6:F17")) Is Nothing Then Call Me.mvp_set
If Not Intersect(target, Range("K6:K17")) Is Nothing Then Call Me.mvp_adj If Not Intersect(Target, Range("K6:K17")) Is Nothing Then Call Me.mvp_adj
If Not Intersect(target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set If Not Intersect(Target, Range("L6:L17")) Is Nothing Then Call Me.mvp_set
If Not Intersect(target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj If Not Intersect(Target, Range("Q6:Q17")) Is Nothing Then Call Me.ms_adj
If Not Intersect(target, Range("R6:R17")) Is Nothing Then Call Me.ms_set If Not Intersect(Target, Range("R6:R17")) Is Nothing Then Call Me.ms_set
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
Set basket_touch = target Set basket_touch = Target
Call Me.get_edit_basket Call Me.get_edit_basket
Set basket_touch = Nothing Set basket_touch = Nothing
End If End If
@ -119,13 +126,13 @@ Private Sub Worksheet_Change(ByVal target As Range)
End If End If
End Sub End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean) Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True cancel = True
Call Me.basket_pick(target) Call Me.basket_pick(Target)
target.Select Target.Select
End If End If
End Sub End Sub
@ -139,12 +146,12 @@ Sub picker_shortcut()
End Sub End Sub
Private Sub Worksheet_BeforeRightClick(ByVal target As Range, cancel As Boolean) Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, cancel As Boolean)
If Not Intersect(target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then If Not Intersect(Target, Range("B33:Q1000")) Is Nothing And Worksheets("config").Cells(6, 2) = 1 Then
cancel = True cancel = True
Call Me.basket_pick(target) Call Me.basket_pick(Target)
target.Select Target.Select
End If End If
End Sub End Sub
@ -387,6 +394,7 @@ Sub load_sheet()
Call Me.set_sheet Call Me.set_sheet
Call Me.print_basket Call Me.print_basket
Call Me.set_format Call Me.set_format
did_load_config = False
End Sub End Sub
@ -474,9 +482,9 @@ Sub set_border(ByRef targ As Range)
End Sub End Sub
Sub fill_yellow(ByRef target As Range) Sub fill_yellow(ByRef Target As Range)
With target.Interior With Target.Interior
.Pattern = xlSolid .Pattern = xlSolid
.PatternColorIndex = xlAutomatic .PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4 .ThemeColor = xlThemeColorAccent4
@ -486,10 +494,10 @@ Sub fill_yellow(ByRef target As Range)
End Sub End Sub
Sub fill_grey(ByRef target As Range) Sub fill_grey(ByRef Target As Range)
With target.Interior With Target.Interior
.Pattern = xlSolid .Pattern = xlSolid
.PatternColorIndex = xlAutomatic .PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1 .ThemeColor = xlThemeColorDark1
@ -499,9 +507,9 @@ Sub fill_grey(ByRef target As Range)
End Sub End Sub
Sub fill_none(ByRef target As Range) Sub fill_none(ByRef Target As Range)
With target.Interior With Target.Interior
.Pattern = xlNone .Pattern = xlNone
.TintAndShade = 0 .TintAndShade = 0
.PatternTintAndShade = 0 .PatternTintAndShade = 0
@ -509,15 +517,15 @@ Sub fill_none(ByRef target As Range)
End Sub End Sub
Sub format_price(ByRef target As Range) Sub format_price(ByRef Target As Range)
target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)" Target.NumberFormat = "_(* #,##0.000_);_(* (#,##0.000);_(* ""-""???_);_(@_)"
End Sub End Sub
Sub format_number(ByRef target As Range) Sub format_number(ByRef Target As Range)
target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)" Target.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
End Sub End Sub
@ -730,45 +738,45 @@ Sub print_basket()
Sheets("month").Cells(31 + i, 17) = basket(i, 4) Sheets("month").Cells(31 + i, 17) = basket(i, 4)
Next i Next i
Rows("20:31").Hidden = True Rows("21:31").Hidden = True
dumping = False dumping = False
End Sub End Sub
Sub basket_pick(ByRef target As Range) Sub basket_pick(ByRef Target As Range)
Dim i As Long Dim i As Long
build.part = Sheets("month").Cells(target.row, 2) build.part = Sheets("month").Cells(Target.row, 2)
build.bill = rev_cust(Sheets("month").Cells(target.row, 6)) build.bill = rev_cust(Sheets("month").Cells(Target.row, 6))
build.ship = rev_cust(Sheets("month").Cells(target.row, 12)) build.ship = rev_cust(Sheets("month").Cells(Target.row, 12))
build.useval = False build.useval = False
build.Show build.Show
If build.useval Then If build.useval Then
dumping = True dumping = True
'if an empty row is selected, force it to be the next open slot 'if an empty row is selected, force it to be the next open slot
If Sheets("month").Cells(target.row, 2) = "" Then If Sheets("month").Cells(Target.row, 2) = "" Then
Do Until Sheets("month").Cells(target.row + i, 2) <> "" Do Until Sheets("month").Cells(Target.row + i, 2) <> ""
i = i - 1 i = i - 1
Loop Loop
i = i + 1 i = i + 1
End If End If
Sheets("month").Cells(target.row + i, 2) = build.cbPart.value Sheets("month").Cells(Target.row + i, 2) = build.cbPart.value
Sheets("month").Cells(target.row + i, 6) = rev_cust(build.cbBill.value) Sheets("month").Cells(Target.row + i, 6) = rev_cust(build.cbBill.value)
Sheets("month").Cells(target.row + i, 12) = rev_cust(build.cbShip.value) Sheets("month").Cells(Target.row + i, 12) = rev_cust(build.cbShip.value)
dumping = False dumping = False
Set basket_touch = Selection Set basket_touch = Selection
Call Me.get_edit_basket Call Me.get_edit_basket
Set basket_touch = Nothing Set basket_touch = Nothing
End If End If
target.Select Target.Select
End Sub End Sub

26
pivot.cls
View File

@ -9,15 +9,19 @@ Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True Attribute VB_Exposed = True
Option Explicit Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean) Private Sub Worksheet_Activate()
If Intersect(target, ActiveSheet.Range("b7:v100000")) Is Nothing Then End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b7:v100000")) Is Nothing Then
Exit Sub Exit Sub
End If End If
On Error GoTo nopiv On Error GoTo nopiv
If target.Cells.PivotTable Is Nothing Then If Target.Cells.PivotTable Is Nothing Then
Exit Sub Exit Sub
End If End If
@ -39,15 +43,15 @@ Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, cancel As Boolean
Dim pi As PivotItem Dim pi As PivotItem
Dim wapi As New Windows_API Dim wapi As New Windows_API
Set ri = target.Cells.PivotCell.RowItems Set ri = Target.Cells.PivotCell.RowItems
Set ci = target.Cells.PivotCell.ColumnItems Set ci = Target.Cells.PivotCell.ColumnItems
Set df = target.Cells.PivotCell.DataField Set df = Target.Cells.PivotCell.DataField
Set rd = target.Cells.PivotTable.RowFields Set rd = Target.Cells.PivotTable.RowFields
Set cd = target.Cells.PivotTable.ColumnFields Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1) ReDim handler.sc(ri.Count, 1)
Set pt = target.Cells.PivotCell.PivotTable Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = "" handler.sql = ""
handler.jsql = "" handler.jsql = ""
@ -116,7 +120,3 @@ Function escape_sql(ByVal text As String) As String
End Function End Function