Last active
March 18, 2021 22:02
-
-
Save vascoferreira25/fffc9948124c6ddf404d654da39fdb2b to your computer and use it in GitHub Desktop.
Remove rows based on a condition and add new columns to a table
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'****************************************************************************** | |
' Author: Vasco Ferreira | |
' Description: Increase performance of Excel when running heavy subs | |
' Version: 0.1 | |
' Instructions: Add this module to the workbook and call its subs | |
' Revisions: TODO | |
' - Date: 2019/03/10 | |
' - Author: Vasco Ferreira | |
' - Description: Init | |
'@Folder("Utilities") | |
Option Explicit | |
'****************************************************************************** | |
'****************************************************************************** | |
' Description: Increase performance by disabling the screen update | |
' and automatic calculations. | |
'****************************************************************************** | |
Public Sub ToggleExcelUpdates(toggle As Boolean) | |
Application.ScreenUpdating = toggle | |
Application.DisplayStatusBar = toggle | |
Application.EnableEvents = toggle | |
If toggle Then | |
Application.Calculation = xlAutomatic | |
Application.Calculate | |
Else | |
Application.Calculation = xlManual | |
End If | |
End Sub | |
'****************************************************************************** | |
' Description: Executes cleanup code at the end of each Sub, re-activates the | |
' current worksheet and shows the Sub runtime. | |
' It can be made public to handle cleanup code on other modules. | |
' Arguments: currentWorksheet | |
' startingTime - value of starting time | |
'****************************************************************************** | |
Public Sub Cleanup(currentWorksheet As Worksheet, startingTime As Double) | |
' Re-enable Screen update and automatic calculations | |
ToggleExcelUpdates True | |
' Re-activate current worksheet | |
currentWorksheet.Activate | |
' Show executionRuntime | |
' MsgBox "Execution time: " & _ | |
(Timer - startingTime) & " seconds.", _ | |
vbOkOnly + vbInformation, "Procedure Execution Time" | |
Debug.Print "Execution time: " & (Timer - startingTime) & " seconds." | |
End Sub | |
'****************************************************************************** | |
' Description: Handles all the errors and executes cleanup code afterwards | |
' It can be made public to handle cleanup code on other modules. | |
' Arguments: currentWorksheet | |
' startingTime - value of starting time | |
'****************************************************************************** | |
Public Sub ErrHandler(currentWorksheet As Worksheet, startingTime As Double) | |
' Handle specific errors | |
Select Case Err.Number | |
Case 0 | |
' No error | |
Case Else | |
' Show the Error Handling form with the error number and message | |
'frm_ErrorHandling.DisplayErrorForm Err.Number, Err.Description | |
Debug.Print "+++ Error: " & Err.Number & ": " & Err.Description | |
End Select | |
Cleanup currentWorksheet, startingTime | |
End Sub |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'****************************************************************************** | |
' Author: TODO | |
' Description: TODO | |
' Version: 0.1 | |
' | |
' Instructions: TODO | |
' | |
' Revisions: TODO | |
' - Date: yyyy/mm/dd | |
' - Author: | |
' - Description: | |
Option Explicit | |
'****************************************************************************** | |
'****************************************************************************** | |
' Description: | |
' Arguments: | |
' Returns: | |
'****************************************************************************** | |
Sub RemoveInvalidDataAndFormatTable() | |
' Start Sub timer | |
Dim executionRuntime As Double | |
executionRuntime = Timer | |
' Turn off screen update and automatic calculations | |
m_CleanupAndPerformance.ToggleExcelUpdates False | |
Dim currentWorkbook As Workbook | |
Dim currentWorksheet As Worksheet | |
' `ThisWorkbook` won't work when an add-in tries to manipulate another | |
' workbook because `ThisWorkbook` will point to the add-in's workbook. | |
Set currentWorkbook = ActiveWorkbook | |
Set currentWorksheet = currentWorkbook.ActiveSheet | |
' When something bad happens, panic! Execute the cleanup to enable excel | |
' updates and calculations again. | |
On Error GoTo ErrorHandling | |
'************************************************************************** | |
Dim curWorksheet As Worksheet | |
For Each curWorksheet In currentWorkbook.workSheets | |
Dim table As Variant | |
For Each table In curWorksheet.ListObjects | |
Dim tableDataRange As Range | |
Set tableDataRange = table.DataBodyRange | |
' Create an array to store the data from the table | |
Dim tableData As BetterArray | |
Set tableData = New BetterArray | |
tableData.FromExcelRange tableDataRange, False, False | |
' Create an array to store the data we want to keep | |
' I hope this is faster than removing and resizing the array | |
Dim finalData As BetterArray | |
Set finalData = New BetterArray | |
' Check which rows you want to keep | |
Dim i As Long | |
For i = 1 To tableData.UpperBound | |
' Filter rows with this condition | |
If tableData(i)(4) < 7000 Then | |
finalData.Push (tableData(i)) | |
End If | |
Next | |
' Pass the data to the worksheet | |
tableDataRange.Clear | |
finalData.ToExcelRange tableDataRange | |
' Add more columns | |
Dim newColumnA As ListColumn | |
Set newColumnA = table.ListColumns.Add | |
newColumnA.Name = "Tax" | |
' Store the data of the new column in a new array | |
Dim columnData As BetterArray | |
Set columnData = New BetterArray | |
' Pushing an array to another makes it 0 index based | |
' So, subtract one from the index you want | |
Dim columnIndex As Integer | |
columnIndex = 4 - 1 | |
Dim j As Long | |
For j = 1 To finalData.UpperBound | |
' Tax is 25% of revenue | |
columnData.Push (finalData(j)(columnIndex) * 0.25) | |
Next | |
' Set the values of the new column | |
columnData.ToExcelRange newColumnA.DataBodyRange | |
Next table | |
Next curWorksheet | |
'************************************************************************** | |
' Enable calculations and screen updates | |
m_CleanupAndPerformance.Cleanup currentWorksheet, executionRuntime | |
Exit Sub | |
ErrorHandling: | |
' If something goes wrong, enable calculations and screen updates | |
m_CleanupAndPerformance.ErrHandler currentWorksheet, executionRuntime | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment