我创建了一个自动宏，它从csv文件中获取车辆崩溃数据并自动创建数据透视表，图表并将其与上一年进行比较。
代码大约有1400行，上传的csv的数据可以是2到100 mb csv文件，超过100,000行和36列。
宏运行正常，但它使机器非常慢，甚至导致它在大多数时间崩溃。如果我选中，要回复电子邮件，它很可能会崩溃。在成功运行之后，宏继续尝试执行某些操作，或者在完成后保持内存占用。
我需要一种优化方法。我已经附加了整个宏的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