Excel VBA

Optimize Application Settings

Dim applicationState(2) As Boolean'Save Application SettingsapplicationState(0) = Application.ScreenUpdatingapplicationState(1) = Application.EnableEventsapplicationState(2) = Application.DisplayAlerts
'Set Application SettingsApplication.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' your code here...
'Reset Application SettingsApplication.StatusBar = ""Application.ScreenUpdating = applicationState(0)Application.EnableEvents = applicationState(1)Application.DisplayAlerts = applicationState(2)

BeforePrint (Event)

Private Sub Workbook_BeforePrint(Cancel As Boolean) 'https://docs.microsoft.com/en-us/office/vba/api/excel.workbook.beforeprint For Each wk in Worksheets wk.Calculate Next End Sub

BeforeClose (Event)

Private Sub Workbook_BeforeClose(Cancel as Boolean) 'https://docs.microsoft.com/en-us/office/vba/api/excel.workbook.beforeclose If Me.Saved = False Then Me.Save End Sub

Before Save (Event)

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _ Cancel as Boolean) 'https://docs.microsoft.com/en-us/office/vba/api/excel.workbook.beforesave a = MsgBox("Do you really want to save the workbook?", vbYesNo) If a = vbNo Then Cancel = True End Sub

Save and Close

'Save and closemyWorkbook.Close savechanges:=True

Sheet Visibility Options

Displays the sheet.

Sheets("sheet name").visible = xlSheetVisible

Hides the worksheet which the user can unhide via menu.

Sheets("sheet name").visible = xlSheetHidden

Hides the object so that the only way for you to make it visible again is by setting this property to True (the user cannot make the object visible).

Sheets("sheet name").visible = xlVeryHidden

Delete Rows with Empty Cells

Sub deleteEmptyRows(keyCol as Integer)' 11JUN2020' Deletes rows where keyCol column is empty
'Active sheet variableDim ws As WorksheetSet ws = ActiveSheet
'Variables for loopsDim x As IntegerDim lastRow As LongDim lastCol As LongDim xRow As Long
'Initialize loop variableslastRow = 1lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'Set lastRow variableFor x = 1 To lastCol xRow = Cells(Rows.Count, x).End(xlUp).row If (xRow > lastRow) Then lastRow = xRow End IfNext
''Use to check that lastRow is correct.'ws.Range("A1", "A" & lastRow).Select
'Delete all rows with no part numberFor x = 1 To lastRow If IsEmpty(ws.Cells(x, keyCol)) Then ws.Rows(x).Delete End IfNext
End Sub

Standardize All Sheets in Workbook

Sub standardizeAllSheets()' 11JUN2020' Resizes columns on all sheets in workbook' Sets headers on all sheets in workbook
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets ws.Activate Columns("A:A").ColumnWidth = 11 Columns("B:B").ColumnWidth = 9 Columns("C:C").ColumnWidth = 10 Columns("D:D").ColumnWidth = 23 Columns("E:E").ColumnWidth = 23 Columns("F:F").ColumnWidth = 23 Columns("G:G").ColumnWidth = 23 Columns("H:H").ColumnWidth = 10 Columns("I:I").ColumnWidth = 10 Cells(1, 1).Value = "Part Number" Cells(1, 2).Value = "Revision" Cells(1, 3).Value = "Package" Cells(1, 4).Value = "Description 1" Cells(1, 5).Value = "Description 2" Cells(1, 6).Value = "Description 3" Cells(1, 7).Value = "Description 4" Cells(1, 8).Value = "Status" Cells(1, 9).Value = "Date"NextEnd Sub

Update an Overview Table

Sub updateOverview()'12JUN2020'Updates overview data
Dim ideaSum As DoubleDim inprogressSum As DoubleDim inreviewSum As DoubleDim approvedSum As DoubleDim ws As WorksheetDim statusRange As Range
inprogressSum = 0inreviewSum = 0approvedSum = 0
For Each ws In ThisWorkbook.Worksheetsws.ActivateSet statusRange = ws.Columns("H")ideaSum = ideaSum - 1 + Application.WorksheetFunction.Countif(ws.Columns("D"), "*")inprogressSum = inprogressSum + Application.WorksheetFunction.Countif(statusRange, "in progress")inreviewSum = inreviewSum + Application.WorksheetFunction.Countif(statusRange, "in review")approvedSum = approvedSum + Application.WorksheetFunction.Countif(statusRange, "approved")Next
Sheets("Overview").ActivateSheets("Overview").Range("B2").Value = ideaSumSheets("Overview").Range("B3").Value = inprogressSumSheets("Overview").Range("B4").Value = inreviewSumSheets("Overview").Range("B5").Value = approvedSumEnd Sub

Delete Unwanted Sheets

Sub removeSheets()'Deletes unwanted worksheets
Dim ws As Worksheet
For Each ws In WorksheetsIf (ws.Name = "ReportForm" Or ws.Name = "ValidationLists" Or ws.Name = "CodeTable") Then'Do NothingElsews.DeleteEnd IfNextEnd Sub

Table Filters

Dim tbl As WorksheetSet tbl = ThisWorkbook.Sheets("TableSheet")
'Filter table by value of a cell'FormSheet is a worksheet that contains the device model in cell B2Dim deviceModel As StringdeviceModel = FormSheet.Range("B2").Valuetbl.ListObjects("myTable").Range.AutoFilter Field:=1, Criteria1:=deviceModel
'Clear all filterstbl.ListObjects("myTable").AutoFilter.ShowAllData

Page updated

Google Sites

Report abuse