内存泄漏在VBA代码

我创build了一个自动macros，它从csv文件中获取车辆碰撞数据，并自动创build数据透视表，图表并将其与前一年进行比较。

该代码长度大约为1400行，上传的csv的数据可以在2到100 mb的csv文件中超过10万行和36列。

macros运行良好，但它使机器非常非常缓慢，甚至导致它崩溃的大部分时间。 如果我选中，回复电子邮件，它很有可能会崩溃。 无论是macros运行成功运行后，还是继续尝试执行某些操作，或者在完成运行后仍然保持内存不变。

我需要一种方法来优化这个。 我已经附加了整个macros的3/4。

码：

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