Memory Leak in vba code - vba

Question

I have created an automated macro which takes vehicle crash data from a csv file and automatically creates pivot table,charts and compares it to the previous year.
The code is approximately 1400 lines long and the data of the uploaded csv can be anywhere between 2 to 100 mb csv files with more than 100,000 rows and 36 columns.
The macro runs fine but it makes the machine very very slow and even causes it to crash most of the times. If I tab, to respond to an email, it has a high probability of crashing. Either the macro is continuing to try to do something after running successfully or it is keeping memory tied up after it has finished.
I need a way to optimize this. I have attached 3/4 of the entire macro.
Code:
Dim YEAR_COL, TYPE_COL As String
Dim CITY_COL, COUNTY_COL As String
Dim DOCNUM_COL, MONTH_COL As String
Dim COUNTY_CITY_COL, CRASH_DATE_COL As String
Dim INJ_TYPE_SERIOUS, INJ_TYPE_FATAL As Integer
Dim G_HEIGHT, G_WIDTH As Integer
Dim G_TOP, G_LEFT As Integer
Dim myColor1(12), myColor2(14) As Long
Dim CURR_YEAR As Integer, PREV_YEAR As Integer
Dim YEAR_NOT_FOUND_MSG As String
Dim INJ_TYPE_NOT_FOUND_MSG As String
Dim CATEGORY_TEXT As String
Dim UPLOADED_DATA_SHEET_NAME As String
Dim CURR_YEAR_SHEET_NAME As String
Dim PREV_YEAR_SHEET_NAME As String
Dim FILTERED_DATA_SHEET_NAME As String, DATA_SHEET_NAME As String
Dim SER_FAT_PLOT_SHEET As String
Dim SER_INJ_DATA_SHEET As String, FAT_INJ_DATA_SHEET As String
Dim SER_INJ_PIVOT_SHEET As String, FAT_INJ_PIVOT_SHEET As String
Dim CHART_SHEET As String
Dim CATEGORY_COL_NAME As String, CATEGORY_COL_NAME2 As String
Dim TOTAL_CATEGORIES As Integer, CATEGORY_TYPE As Integer
Dim SER_UNRESTRAINED_COL_NAME As String, FAT_UNRESTRAINED_COL_NAME As String
Dim ALCOHOL_COL_NAME As String, SPEED_COL_NAME As String
Dim TEEN_DRIVER_COL_NAME As String, OLD_DRIVER_COL_NAME As String
Dim DISTRACTION_COL_NAME As String, MOTORCYCLE_COL_NAME As String
Dim CMV_COL_NAME As String, BICYCLE_COL_NAME As String
Dim PEDESTRIAN_COL_NAME As String, LRG_TRUCK_COL_NAME As String
Dim CHART1_TITLE As String, CHART2_TITLE As String
Dim CHART3_TITLE As String, CHART4_TITLE As String
Dim INCREMENT_ROWS As Integer
Dim USE_EXISTING_DATA As Boolean
Private Sub InitializeVars()
TYPE_COL = "MinInjuryTypeID"
YEAR_COL = "Year"
CITY_COL = "City_Name"
COUNTY_COL = "County_Name"
COUNTY_CITY_COL = "County_City"
DOCNUM_COL = "DocumentNumber"
MONTH_COL = "MonthName"
CRASH_DATE_COL = "CrashDate"
INJ_TYPE_SERIOUS = 2
INJ_TYPE_FATAL = 1
CURR_YEAR = year(Now())
PREV_YEAR = CURR_YEAR - 1
TOTAL_YEARS = 5
CURR_YEAR_SHEET_NAME = "" & CURR_YEAR
PREV_YEAR_SHEET_NAME = "" & PREV_YEAR
INCREMENT_ROWS = 7500
' Speed, Alcohol, Unbelted, teen, old, texting, distraction
CATEGORY_TYPE = 0
CATEGORY_COL_NAME = ""
CATEGORY_COL_NAME2 = ""
FAT_UNRESTRAINED_COL_NAME = "unrestrainedFatals"
SER_UNRESTRAINED_COL_NAME = "UnrestrainedInjuries"
SPEED_COL_NAME = "Speed"
ALCOHOL_COL_NAME = "Alcohol"
CMV_COL_NAME = "CMV"
BICYCLE_COL_NAME = "Bicycle"
PEDESTRIAN_COL_NAME = "Pedestrian"
MOTORCYCLE_COL_NAME = "Motorcycle"
TEEN_DRIVER_COL_NAME = "TeenDriverInvolved"
OLD_DRIVER_COL_NAME = "OlderDriverInv"
LRG_TRUCK_COL_NAME = "LrgTruck"
DISTRACTION_COL_NAME = "DistractionInvolved"
YEAR_NOT_FOUND_MSG = "Please enter column name for filtering injury records by Year."
INJ_TYPE_NOT_FOUND_MSG = "Please enter column name for filtering by Injury Type."
G_TOP = 20
G_LEFT = 20
G_WIDTH = 2000
G_HEIGHT = 530
UPLOADED_DATA_SHEET_NAME = "Uploaded Data"
FILTERED_DATA_SHEET_NAME = "Filtered Data"
DATA_SHEET_NAME = "Data"
SER_INJ_DATA_SHEET = "Data(Ser_Injuries)"
FAT_INJ_DATA_SHEET = "Data(Fatalities)"
SER_INJ_PIVOT_SHEET = "Serious Injuries by County_City"
FAT_INJ_PIVOT_SHEET = "Fatalities by County_City"
SER_FAT_PLOT_SHEET = "Ser_Inj_Fatalities_Plot_Data"
CHART_SHEET = "Plots"
' color codes for difference chart
myColor1(1) = RGB(209, 190, 184)
myColor1(2) = RGB(196, 161, 149)
myColor1(3) = RGB(186, 133, 115)
myColor1(4) = RGB(191, 112, 86)
myColor1(5) = RGB(179, 85, 54)
myColor1(6) = RGB(163, 107, 88)
myColor1(7) = RGB(158, 93, 46)
myColor1(8) = RGB(191, 76, 38)
myColor1(9) = RGB(184, 56, 13)
myColor1(10) = RGB(145, 74, 23)
myColor1(11) = RGB(140, 42, 10)
myColor1(12) = RGB(115, 45, 22)
' color codes for total and difference chart
myColor2(1) = RGB(209, 190, 184)
myColor2(2) = RGB(196, 161, 149)
myColor2(3) = RGB(186, 133, 115)
myColor2(4) = RGB(191, 112, 86)
myColor2(5) = RGB(179, 85, 54)
myColor2(6) = RGB(163, 107, 88)
myColor2(7) = RGB(158, 93, 46)
myColor2(8) = RGB(191, 76, 38)
myColor2(9) = RGB(184, 56, 13)
myColor2(10) = RGB(145, 74, 23)
myColor2(11) = RGB(140, 42, 10)
myColor2(12) = RGB(115, 45, 22)
myColor2(13) = RGB(7, 162, 240)
myColor2(14) = RGB(255, 0, 0)
End Sub
Sub RunFullMacro()
Dim strFile As String
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Call InitializeVars
'Call GetYearFromUser
strFile = GetYearForComparison()
Call GetFilterCategory
If USE_EXISTING_DATA = False Then
Call ImportCurrentYearCSV(strFile)
Call MoveDataToProperSheets(CURR_YEAR, CURR_YEAR_SHEET_NAME)
Call MoveDataToProperSheets(PREV_YEAR, PREV_YEAR_SHEET_NAME)
End If
CHART1_TITLE = "Difference in serious injuries" & CATEGORY_TEXT & " (" & PREV_YEAR & " - " & CURR_YEAR & ")"
CHART2_TITLE = "Difference in fatal injuries" & CATEGORY_TEXT & " (" & PREV_YEAR & " - " & CURR_YEAR & ")"
CHART3_TITLE = "Total number of crashes" & CATEGORY_TEXT & " with difference in number of serious injuries by month between " & _
PREV_YEAR & " and " & CURR_YEAR
CHART4_TITLE = "Total number of crashes" & CATEGORY_TEXT & " with difference in number of fatal injuries by month between " & _
PREV_YEAR & " and " & CURR_YEAR
Call CreateInitialDataSheets
Call ConcatenateColumns
Call CreateFilteredDataSheets
Call CreatePivotTables
Call CreatePlots
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub GetYearFromUser()
Dim userYear As String
Dim msg As String
msg = ""
EnterYear:
userYear = InputBox(Prompt:=msg & "Enter Year for comparing data:", title:="Year for comparing data")
' If no data entered, exit application
If userYear = "" Or userYear = vbNullString Then
MsgBox "Invalid Year." & vbNewLine & "Exiting."
End
ElseIf IsNumeric(userYear) = True Then
If CInt(userYear) > year(Now()) Then
msg = "Invalid Year. "
GoTo EnterYear
Else
CURR_YEAR = userYear
PREV_YEAR = CInt(userYear) - 1
End If
Else
msg = "Invalid Year. "
GoTo EnterYear
End If
' reinitialize variables
CURR_YEAR_SHEET_NAME = "" & CURR_YEAR
PREV_YEAR_SHEET_NAME = "" & PREV_YEAR
End Sub
Private Function GetYearForComparison()
Dim strFile As String
Dim answer As Integer
strFile = ""
If SheetExists(PREV_YEAR_SHEET_NAME) = False Or SheetExists(CURR_YEAR_SHEET_NAME) = False Then
USE_EXISTING_DATA = False
Else
USE_EXISTING_DATA = True
End If
If USE_EXISTING_DATA = True Then
answer = MsgBox("Do you want to use the existing data for comparison?", vbYesNo, "Use existing data")
If answer = vbYes Or answer = 6 Then
USE_EXISTING_DATA = True
Else
USE_EXISTING_DATA = False
End If
End If
' import sheet for current selected year
If USE_EXISTING_DATA = False Then
' strFile = "Macintosh HD:Users:sneha.banerjee:Sites:XLS:2016.csv"
' MsgBox "Uploading Data"
strFile = Application.GetOpenFilename("Csv Files (*.csv), *.csv", , "Please select a CSV file")
If strFile = "" Or strFile = vbNullString Then
'USE_EXISTING_DATA = True
MsgBox "Exiting..."
End
End If
End If
GetYearForComparison = strFile
End Function
Private Function SheetExists(ByVal name As String) As Boolean
On Error GoTo ReturnFalse
Sheets(name).Activate
' Sheet exists
SheetExists = True
Exit Function
ReturnFalse:
SheetExists = False
End Function
Private Sub ImportCurrentYearCSV(ByVal strFile As String)
Dim dataSheet As Worksheet
' assume previous years sheet already stored, store entered sheet as current year sheet
Call Get_Sheet(UPLOADED_DATA_SHEET_NAME, True)
Sheets(UPLOADED_DATA_SHEET_NAME).Activate
Set dataSheet = ActiveSheet
With dataSheet.QueryTables.Add(Connection:= _
"TEXT;" & strFile, Destination:=Range("A1"))
.name = "Uploaded Data"
.RefreshOnFileOpen = False
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.TextFilePromptOnRefresh = False
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
End With
Application.CutCopyMode = False
'Move current year sheet after previous year
'currYearSheet.Move after:=Sheets(UPLOADED_DATA_SHEET_NAME)
'Move initial data sheet after current year
'Call Get_Sheet(DATA_SHEET_NAME, True)
'Sheets(DATA_SHEET_NAME).Move after:=Sheets(CURR_YEAR_SHEET_NAME)
End Sub
Private Sub MoveDataToProperSheets(ByVal CurrYear As Integer, ByVal sheetName As String)
Dim colNo As Integer
Dim rng1 As Range
Sheets(UPLOADED_DATA_SHEET_NAME).Activate
colNo = Search_ColumnWithTitle(YEAR_COL, "Please enter column name for Year")
With ActiveSheet
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter Field:=colNo, Criteria1:="" & CurrYear, Operator:=xlFilterValues
End With
Set rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeVisible)
If rng1.Rows.count <= 1 Then
' Do nothing
Else
Call Get_Sheet(sheetName, True)
' Copy curr year's data to proper data sheet
Call CopyInPartsSpecial(UPLOADED_DATA_SHEET_NAME, rng1, sheetName)
End If
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
End Sub
Private Function Select_File_Mac() As String
Dim MyScript As String
Dim MyFile As String
'#If Mac Then
' strFile = Select_File_Mac()
'#Else
' strFile = Application.GetOpenFilename("Csv Files (*.csv), *.csv", , "Please select a CSV file")
'#End If¼
On Error Resume Next
' In the following statement, change true to false in the line "multiple
' selections allowed true" if you do not want to be able to select more
' than one file. Additionally, if you want to filter for multiple files, change
' {""com.microsoft.Excel.xls""} to
' {""com.microsoft.excel.xls"",""public.comma-separated-values-text""}
' if you want to filter on xls and csv files, for example.
MyScript = _
"set applescript's text item delimiters to "","" " & vbNewLine & _
"set the Files to (choose file of type " & _
" {""public.comma-separated-values-text""} " & _
"with prompt ""Please select a file"" default location alias """ & _
""" multiple selections allowed false) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return the Files"
MyFile = MacScript(MyScript)
On Error GoTo 0
If MyFile <> "" Then
Select_File_Or_Files_Mac = MyFile
Else
Select_File_Or_Files_Mac = ""
End If
End Function
Private Sub CreateInitialDataSheets()
Dim ws As Worksheet
Dim rng As Range
Dim rng2 As Range, destCell As Range
' validate data for curr and prev years exist
If SheetExists(PREV_YEAR_SHEET_NAME) = False Then
MsgBox "Data for " & PREV_YEAR & " not found. Upload data and try again. " & vbNewLine & "Exiting."
End
ElseIf SheetExists(CURR_YEAR_SHEET_NAME) = False Then
MsgBox "Data for " & CURR_YEAR & " not found. Upload data and try again. " & vbNewLine & "Exiting."
End
End If
' Get latest date of current year data
Call Get_Sheet(DATA_SHEET_NAME, True)
Sheets(CURR_YEAR_SHEET_NAME).Activate
colNo = Search_ColumnWithTitle(CRASH_DATE_COL, "Please enter column name for Crash Date")
col2 = Search_ColumnWithTitle(TYPE_COL, "Please enter column name for Injury type")
lastRow = Get_LastRowNo(1)
lastCol = Get_LastColumnNo()
Set rng = ActiveSheet.Range(ActiveSheet.Cells(2, colNo), ActiveSheet.Cells(lastRow, colNo))
maxDate = Application.WorksheetFunction.Max(rng) - 365
' Get data less than equal to max date of previous year
Sheets(PREV_YEAR_SHEET_NAME).Activate
colNo = Search_ColumnWithTitle(CRASH_DATE_COL, "Please enter column name for Crash Date")
With ActiveSheet
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter Field:=colNo, Criteria1:="<=" & maxDate, Operator:=xlFilterValues
End With
' Copy previous year's data to data sheet
'ActiveSheet.Cells.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(DATA_SHEET_NAME).Range("A1")
Call CopyInPartsSpecial(PREV_YEAR_SHEET_NAME, ActiveSheet.Cells.SpecialCells(xlCellTypeVisible), DATA_SHEET_NAME)
On Error GoTo Proceed
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
Proceed:
'Copy all current year to data sheet
Sheets(CURR_YEAR_SHEET_NAME).Activate
Set ws = ActiveSheet
Set rng2 = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))
'Set destCell = Sheets(DATA_SHEET_NAME).Cells(Rows.Count, "A").End(xlUp).Offset(1)
'rng2.Copy Destination:=destCell
Call CopyInPartsSpecial(CURR_YEAR_SHEET_NAME, rng2, DATA_SHEET_NAME)
On Error GoTo Proceed1
Sheets(DATA_SHEET_NAME).Activate
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
Columns.AutoFit
Proceed1:
End Sub
Private Sub CreateFilteredDataSheets()
Dim colNo As Integer
If CATEGORY_TYPE = 0 Then
Application.DisplayAlerts = False
Call Get_Sheet(FILTERED_DATA_SHEET_NAME, True)
Sheets(FILTERED_DATA_SHEET_NAME).Delete
FILTERED_DATA_SHEET_NAME = DATA_SHEET_NAME
Application.DisplayAlerts = True
GoTo Exitsub
End If
' copy filtered data to new sheet
Call Get_Sheet(FILTERED_DATA_SHEET_NAME, True)
Sheets(DATA_SHEET_NAME).Activate
colNo = Search_ColumnWithTitle(CATEGORY_COL_NAME, "Please enter column name for Accident category")
If CATEGORY_TYPE = 3 Then
colNo = GetCategoryColumn()
With ActiveSheet
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter Field:=colNo, Criteria1:=">=1", Operator:=xlFilterValues
End With
Else
With ActiveSheet
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter Field:=colNo, Criteria1:=Array("Y", "YES"), Operator:=xlFilterValues
End With
End If
' Copy filtered data to new sheet
Call CopyInPartsSpecial(DATA_SHEET_NAME, ActiveSheet.Cells.SpecialCells(xlCellTypeVisible), FILTERED_DATA_SHEET_NAME)
On Error GoTo Proceed
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
Proceed:
' Delete temporary column
If CATEGORY_TYPE = 3 Then
Sheets(DATA_SHEET_NAME).Columns(colNo).ClearContents
End If
Exitsub:
Sheets(FILTERED_DATA_SHEET_NAME).Activate
Columns.AutoFit
End Sub
Private Sub ConcatenateColumns()
Dim col1 As Integer, col2 As Integer
Dim rowCount As Long, resultCol As Integer
Sheets(DATA_SHEET_NAME).Activate
col1 = Search_ColumnWithTitle(COUNTY_COL, "Please enter column name for County")
col2 = Search_ColumnWithTitle(CITY_COL, "Please enter column name for City")
rowCount = Get_LastRowNo(1)
' Find first available column for results
If IsError(Application.Match(COUNTY_CITY_COL, Range(Cells(1, 1), Cells(1, Columns.count)), 0)) Then
' column not present, find first empty column
resultCol = Get_LastColumnNo() + 1
Else
' column already present, clear it
resultCol = Application.Match(COUNTY_CITY_COL, Range(Cells(1, 1), Cells(1, Columns.count)), 0)
Columns(resultCol).ClearContents
End If
' Populate Final results
Cells(1, resultCol).value = COUNTY_CITY_COL
For rowNo = 2 To rowCount
Cells(rowNo, resultCol).value = Trim(Cells(rowNo, col1).value & Cells(rowNo, col2).value)
Next
Columns(resultCol).Select
Selection.EntireColumn.AutoFit
Application.CutCopyMode = False
End Sub
Private Function GetCategoryColumn()
Dim col1 As Integer, col2 As Integer
Dim rowCount As Long, resultCol As Integer
Sheets(DATA_SHEET_NAME).Activate
col1 = Search_ColumnWithTitle(CATEGORY_COL_NAME, "Please enter column name for Unbelted Fatalities")
col2 = Search_ColumnWithTitle(CATEGORY_COL_NAME2, "Please enter column name for Unbelted Serious Injuries")
rowCount = Get_LastRowNo(1)
resultCol = Get_LastColumnNo() + 1
' Populate Final values
Cells(1, resultCol).value = "TEMP_COL"
For rowNo = 2 To rowCount
If IsTrue(Cells(rowNo, col1).value) Or IsTrue(Cells(rowNo, col2).value) Then
Cells(rowNo, resultCol).value = 1
Else
Cells(rowNo, resultCol).value = 0
End If
Next
Columns(resultCol).Select
Selection.EntireColumn.AutoFit
Application.CutCopyMode = False
GetCategoryColumn = resultCol
End Function
Private Function IsTrue(ByVal value As String) As Boolean
Dim returnValue As Integer
If IsNumeric(value) Then
If CInt(value) > 0 Then
returnValue = 1
Else
returnValue = 0
End If
ElseIf value = "YES" Or value = "Y" Then
returnValue = 1
Else
returnValue = 0
End If
IsTrue = returnValue
End Function
Private Sub CreatePivotTables()
Dim colNo As Integer
Sheets(FILTERED_DATA_SHEET_NAME).Activate
colNo = Search_ColumnWithTitle(TYPE_COL, INJ_TYPE_NOT_FOUND_MSG)
Call CreateDataSheet(INJ_TYPE_SERIOUS, colNo, SER_INJ_DATA_SHEET)
Call CreateDataSheet(INJ_TYPE_FATAL, colNo, FAT_INJ_DATA_SHEET)
On Error GoTo Proceed
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
Proceed:
Sheets(SER_INJ_DATA_SHEET).Activate
Call CreatePivotTable(SER_INJ_PIVOT_SHEET)
Sheets(FAT_INJ_DATA_SHEET).Activate
Call CreatePivotTable(FAT_INJ_PIVOT_SHEET)
End Sub
Private Sub CreateDataSheet(ByVal val As Integer, ByVal colNo As Integer, ByVal sheetName As String)
With ActiveSheet
.AutoFilterMode = False
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter
.Range(Cells(1, 1), Cells(1, Columns.count)).AutoFilter Field:=colNo, Criteria1:=val
End With
' verify sheet is present and clear it, else create new
Call Get_Sheet(sheetName, True)
' copy data sheet to new sheet
Sheets(FILTERED_DATA_SHEET_NAME).Activate
'ActiveSheet.Cells.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(sheetName).Range("A1")
Call CopyInPartsSpecial(FILTERED_DATA_SHEET_NAME, ActiveSheet.Cells.SpecialCells(xlCellTypeVisible), sheetName)
On Error GoTo Proceed
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
ActiveSheet.AutoFilterMode = False
End If
Proceed:
Sheets(sheetName).Activate
Columns.AutoFit
Sheets(FILTERED_DATA_SHEET_NAME).Activate
End Sub
Private Sub CreatePivotTable(ByVal pvtShtName As String)
Dim pivotSheet As Worksheet
Dim dataSheet As String
dataSheet = ActiveSheet.name
' Create Pivot Sheet
Call Get_Sheet(pvtShtName, True)
Set pivotSheet = Sheets(pvtShtName)
' select data source for pivot table
Sheets(dataSheet).Activate
resultCol = Application.Match(COUNTY_CITY_COL, Range(Cells(1, 1), Cells(1, Columns.count)), 0)
rowCount = Get_LastRowNo(1)
srcData = ActiveSheet.name & "!" & Range(Cells(1, 1), Cells(rowCount, resultCol)).Address(ReferenceStyle:=xlR1C1)
' Create Pivot Cache from Source Data
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=srcData)
pivotSheet.Activate
Set pvt = pvtCache.CreatePivotTable(TableDestination:=Range("A1"), TableName:="PT_" & pvtShtName)
' Specify row and column fields
With pvt.PivotFields(YEAR_COL)
.Orientation = xlColumnField
.PivotFilters.Add Type:=xlCaptionIsGreaterThanOrEqualTo, Value1:=PREV_YEAR
End With
pvt.PivotFields(MONTH_COL).Orientation = xlColumnField
With pvt.PivotFields(COUNTY_CITY_COL)
.Orientation = xlRowField
.AutoSort xlAscending, COUNTY_CITY_COL
End With
With pvt.PivotFields(DOCNUM_COL)
.Orientation = xlDataField
.Function = xlCount
End With
Application.CutCopyMode = False
End Sub
Private Function Get_LastRowNo(ByVal colNo As Integer) As Long
Get_LastRowNo = Cells(Rows.count, colNo).End(xlUp).Row
End Function
Private Function Get_LastColumnNo() As Integer
Get_LastColumnNo = Cells(1, Columns.count).End(xlToLeft).Column
End Function
Private Function Get_Sheet(ByVal sheetName As String, ByVal clearSheet As Boolean) As Boolean
Dim ws As Worksheet
Dim dataSheet As String
Dim chtObj As ChartObject
' Check if sheet present, if not create new
dataSheet = ActiveSheet.name
On Error GoTo CreateSheet
Set ws = Sheets(sheetName)
If clearSheet = True Then
ws.Cells.Clear
End If
' Delete all existing charts
For Each chtObj In ws.ChartObjects
chtObj.Delete
Next
Sheets(dataSheet).Activate
Get_Sheet = False
Exit Function
CreateSheet:
' If current sheet empty, rename it and use it
If ActiveSheet.UsedRange.Rows.count = 1 _
And ActiveSheet.UsedRange.Columns.count = 1 And Cells(1, 1).value = "" Then
ActiveSheet.name = sheetName
Else
Sheets.Add(, ActiveSheet).name = sheetName
Sheets(dataSheet).Activate
End If
Get_Sheet = True
End Function
' Assuming ActiveSheet and title on Row 1
Private Function Search_ColumnWithTitle(ByVal title As String, ByVal msg As String) As Integer
CheckColumn:
If IsError(Application.Match(title, Range(Cells(1, 1), Cells(1, Columns.count)), 0)) Then
title = InputBox(Prompt:="Column '" & title & "' not found. " & msg, _
title:="Enter " & title & " column name")
If title = "" Or title = vbNullString Then
MsgBox "No column name entered. Exiting..."
End
Else
GoTo CheckColumn
End If
End If
Search_ColumnWithTitle = Application.Match(title, Range(Cells(1, 1), Cells(1, Columns.count)), 0)
End Function
Private Sub GetFilterCategory()
Dim categoryNum As String
Dim text As String
TOTAL_CATEGORIES = 11
text = "0. All categories" & vbNewLine & _
"1. Alcohol" & vbNewLine & _
"2. Speed" & vbNewLine & _
"3. Unrestrained" & vbNewLine & _
"4. CMV" & vbNewLine & _
"5. Bicylce" & vbNewLine & _
"6. Pedestrian" & vbNewLine & _
"7. Motorcycle" & vbNewLine & _
"8. Teen driver involved" & vbNewLine & _
"9. Older driver involved" & vbNewLine & _
"10. Large Truck" & vbNewLine & _
"11. Distraction involved" & vbNewLine & _
"Enter the category number to be filtered"
categoryNum = InputBox(Prompt:=text, title:="Filter accidents by category")
If IsNumeric(categoryNum) Then
If CInt(categoryNum) >= 0 And CInt(categoryNum) <= TOTAL_CATEGORIES Then
CATEGORY_TYPE = CInt(categoryNum)
Else
CATEGORY_TYPE = 0
End If
Else
MsgBox "Invalid Entry. Exiting..."
End
End If
Select Case CATEGORY_TYPE
Case 1
CATEGORY_COL_NAME = ALCOHOL_COL_NAME
CATEGORY_TEXT = " - Alcohol -"
Case 2
CATEGORY_COL_NAME = SPEED_COL_NAME
CATEGORY_TEXT = " - Speeding -"
Case 3
CATEGORY_COL_NAME = FAT_UNRESTRAINED_COL_NAME
CATEGORY_COL_NAME2 = SER_UNRESTRAINED_COL_NAME
CATEGORY_TEXT = " - Unrestrained -"
Case 4
CATEGORY_COL_NAME = CMV_COL_NAME
CATEGORY_TEXT = " - CMV -"
Case 5
CATEGORY_COL_NAME = BICYCLE_COL_NAME
CATEGORY_TEXT = " - Bicycle -"
Case 6
CATEGORY_COL_NAME = PEDESTRIAN_COL_NAME
CATEGORY_TEXT = " - Pedestrian -"
Case 7
CATEGORY_COL_NAME = MOTORCYCLE_COL_NAME
CATEGORY_TEXT = " - Motorcycle -"
Case 8
CATEGORY_COL_NAME = TEEN_DRIVER_COL_NAME
CATEGORY_TEXT = " - Teen driver -"
Case 9
CATEGORY_COL_NAME = OLD_DRIVER_COL_NAME
CATEGORY_TEXT = " - Older driver -"
Case 10
CATEGORY_COL_NAME = LRG_TRUCK_COL_NAME
CATEGORY_TEXT = " - Large truck -"
Case 11
CATEGORY_COL_NAME = DISTRACTION_COL_NAME
CATEGORY_TEXT = " - Distraction -"
Case Else
CATEGORY_COL_NAME = ""
CATEGORY_TEXT = ""
End Select
End Sub
Private Function ExitIfColumnNotFound(ByVal colName As String)
If IsError(Application.Match(colName, Range(Cells(1, 1), Cells(1, Columns.count)), 0)) Then
MsgBox "Column '" & colName & "' not found. Exiting..."
End
End If
End Function