sbanerjee1987
New Member
- Joined
- Apr 24, 2016
- Messages
- 2
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 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
Private Function GetNumberOfMonths(ByVal sheetName As String) As Integer
Dim prev_year_start_col As Integer, curr_year_start_col As Integer
Dim colNo As Integer, diff As Integer
Sheets(sheetName).Activate
monthNo = 1
prev_year_start_col = 0
curr_year_start_col = 0
On Error Resume Next
curr_year_start_col = Application.Match(CURR_YEAR, Range(Cells(2, 1), Cells(2, Columns.count)), 0)
On Error Resume Next
prev_year_start_col = Application.Match(CURR_YEAR, Range(Cells(2, 1), Cells(2, Columns.count)), 0)
' get max number of months
If curr_year_start_col = 0 And prev_year_start_col = 0 Then
monthNo = 0
colNo = 0
ElseIf curr_year_start_col = 0 Then
colNo = prev_year_start_col
Else
colNo = curr_year_start_col
End If
If colNo > 0 Then
While Cells(3, colNo).value <> ""
monthNo = Month("1-" & Cells(3, colNo).value & "-2000")
colNo = colNo + 1
Wend
End If
GetNumberOfMonths = monthNo
End Function
Private Function CopyPivotTable(ByVal sheetName As String, ByVal destStartRow As Integer, ByVal numMonths As Integer) As Variant
' Return value: [startRow, startCol, endRow, endCol]
Dim V(0 To 3) As Variant
Dim rowNo As Integer, colNo As Integer
Dim recordsCount As Integer, srcLastRow As Integer
Dim srcStartCol As Integer, destCurrColNo As Integer
Dim currYearCol As Integer, lastRow As Integer
Set src = Sheets(sheetName)
Set dest = Sheets(SER_FAT_PLOT_SHEET)
Sheets(sheetName).Activate
srcLastRow = Get_LastRowNo(1)
recordsCount = srcLastRow - 2 ' excluding 2 rows for headers
destCurrColNo = 1
' Copy Row Labels i.e. first column
src.Range(src.Cells(3, 1), src.Cells(srcLastRow, 1)).Copy Destination:=dest.Cells(destStartRow + 1, destCurrColNo)
dest.Columns.AutoFit
destCurrColNo = destCurrColNo + 1
' Copy prev year data
destStartCol = 2
' column 1 is row header
srcStartCol = -1 ' in case no data for curr year
On Error Resume Next
srcStartCol = Application.Match(PREV_YEAR, src.Range(Cells(2, 1), src.Cells(2, Columns.count)), 0)
monthNo = 1
' no data for curr year
If srcStartCol = -1 Then
For colNo = 1 To numMonths
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
monthNo = monthNo + 1
destCurrColNo = destCurrColNo + 1
Next colNo
Else
For colNo = srcStartCol To srcStartCol + numMonths - 1
monName = src.Cells(3, colNo).value
' if month column missing, add it
If IsEmpty(monName) Or Len(monName) = 0 Then
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
colNo = colNo - 1
ElseIf Month("1-" & monName & "-2000") = monthNo Then
src.Range(src.Cells(2, colNo), src.Cells(srcLastRow, colNo)).Copy Destination:=dest.Cells(destStartRow, destCurrColNo)
Else
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
colNo = colNo - 1
End If
monthNo = monthNo + 1
destCurrColNo = destCurrColNo + 1
' exit if all months copied
If monthNo > numMonths Then
Exit For
End If
Next colNo
End If
' copy formatting
src.Range(src.Cells(1, 1), src.Cells(1, numMonth + 2)).Copy
dest.Cells(destStartRow, destCurrColNo).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Total of the copied rows excluding headers
dest.Cells(destStartRow + 1, destCurrColNo).value = PREV_YEAR & " Total"
For rowNo = (destStartRow + 2) To (destStartRow + recordsCount)
If srcStartCol = -1 Then
dest.Cells(rowNo, destCurrColNo).value = 0
Else
dest.Cells(rowNo, destCurrColNo).value = Application.Sum(dest.Range(dest.Cells(rowNo, destStartCol), _
dest.Cells(rowNo, destStartCol + numMonths - 1)))
End If
Next rowNo
' copy formatting
dest.Cells(destStartRow + recordsCount, destCurrColNo - 1).Copy
dest.Cells(destStartRow + recordsCount, destCurrColNo).PasteSpecial Paste:=xlPasteFormats
destCurrColNo = destCurrColNo + 1
' ----------------------------------------------------------'
' Copy curr year data
srcStartCol = -1 ' in case no data for curr year
On Error Resume Next
srcStartCol = Application.Match(CURR_YEAR, src.Range(Cells(2, 1), src.Cells(2, Columns.count)), 0)
destStartCol = destCurrColNo
monthNo = 1
' no data for curr year
If srcStartCol = -1 Then
For colNo = 1 To numMonths
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
monthNo = monthNo + 1
destCurrColNo = destCurrColNo + 1
Next colNo
Else
For colNo = srcStartCol To srcStartCol + numMonths - 1
monName = src.Cells(3, colNo).value
' if month column missing, add it
If IsEmpty(monName) Or Len(monName) = 0 Then
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
colNo = colNo - 1
ElseIf Month("1-" & monName & "-2000") = monthNo Then
src.Range(src.Cells(2, colNo), src.Cells(srcLastRow, colNo)).Copy Destination:=dest.Cells(destStartRow, destCurrColNo)
Else
dest.Cells(destStartRow + 1, destCurrColNo).value = MonthName(monthNo)
For i = (destStartRow + 2) To (destStartRow + recordsCount)
dest.Cells(i, destCurrColNo).value = 0
Next i
colNo = colNo - 1
End If
monthNo = monthNo + 1
destCurrColNo = destCurrColNo + 1
' exit if all months copied
If monthNo > numMonths Then
Exit For
End If
Next colNo
End If
' copy formatting
src.Range(src.Cells(1, 1), src.Cells(1, numMonth + 2)).Copy
dest.Cells(destStartRow, destCurrColNo).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Total of the copied rows excluding headers
dest.Cells(destStartRow + 1, destCurrColNo).value = CURR_YEAR & " Total"
For rowNo = (destStartRow + 2) To (destStartRow + recordsCount)
If srcStartCol = -1 Then
dest.Cells(rowNo, destCurrColNo).value = 0
Else
dest.Cells(rowNo, destCurrColNo).value = Application.Sum(dest.Range(dest.Cells(rowNo, destStartCol), _
dest.Cells(rowNo, destStartCol + numMonths - 1)))
End If
Next rowNo
' copy formatting
dest.Cells(destStartRow + recordsCount, destCurrColNo - 1).Copy
dest.Cells(destStartRow + recordsCount, destCurrColNo).PasteSpecial Paste:=xlPasteFormats
destCurrColNo = destCurrColNo + 1
' Calculate difference
Sheets(SER_FAT_PLOT_SHEET).Activate
destCurrColNo = destCurrColNo + 1
V(0) = destStartRow + 1
V(1) = destCurrColNo
' Copy Row Labels i.e. first column
dest.Range(dest.Cells(destStartRow + 2, 1), dest.Cells(destStartRow + recordsCount, 1)).Copy _
Destination:=dest.Cells(destStartRow + 2, destCurrColNo)
destCurrColNo = destCurrColNo + 1
' Copy column headings
For colNo = 2 To numMonths + 1
dest.Range(dest.Cells(destStartRow + 1, 2), dest.Cells(destStartRow + 1, 1 + numMonths)).Copy _
Destination:=dest.Cells(destStartRow + 1, destCurrColNo)
Next colNo
dest.Columns.AutoFit
' subtract prev year from curr year
currYearCol = numMonths + 3
lastRow = recordsCount + destStartRow
For prevYearCol = 2 To numMonths + 1
For rowNo = destStartRow + 2 To lastRow
dest.Cells(rowNo, destCurrColNo) = dest.Cells(rowNo, currYearCol) - dest.Cells(rowNo, prevYearCol)
Next rowNo
destCurrColNo = destCurrColNo + 1
currYearCol = currYearCol + 1
Next prevYearCol
V(2) = lastRow
' copy totals columns
prevYearTotalCol = 2 + numMonths
dest.Range(dest.Cells(destStartRow + 1, prevYearTotalCol), dest.Cells(destStartRow + recordsCount, prevYearTotalCol)).Copy _
Destination:=dest.Cells(destStartRow + 1, destCurrColNo)
destCurrColNo = destCurrColNo + 1
currYearTotalCol = prevYearTotalCol + numMonths + 1
dest.Range(dest.Cells(destStartRow + 1, currYearTotalCol), dest.Cells(destStartRow + recordsCount, currYearTotalCol)).Copy _
Destination:=dest.Cells(destStartRow + 1, destCurrColNo)
V(3) = destCurrColNo
Application.CutCopyMode = False
CopyPivotTable = V
End Function
Private Sub CreatePlots()
Dim numMonths As Integer, top As Integer
Dim ser_data As Variant, fat_data As Variant
months1 = GetNumberOfMonths(SER_INJ_PIVOT_SHEET)
months2 = GetNumberOfMonths(FAT_INJ_PIVOT_SHEET)
If months1 >= months2 Then
numMonths = months1
Else
numMonths = months2
End If
' Copy and calculate sum and difference
Call Get_Sheet(SER_FAT_PLOT_SHEET, True)
startRow1 = 1
ser_data = CopyPivotTable(SER_INJ_PIVOT_SHEET, startRow1, numMonths)
Call FillGaps(FILTERED_DATA_SHEET_NAME, SER_FAT_PLOT_SHEET, ser_data)
Sheets(SER_FAT_PLOT_SHEET).Activate
ser_data(2) = Get_LastRowNo(1)
Sheets(SER_FAT_PLOT_SHEET).Activate
startRow2 = Get_LastRowNo(1) + 3
fat_data = CopyPivotTable(FAT_INJ_PIVOT_SHEET, startRow2, numMonths)
Call FillGaps(FILTERED_DATA_SHEET_NAME, SER_FAT_PLOT_SHEET, fat_data)
Sheets(SER_FAT_PLOT_SHEET).Activate
fat_data(2) = Get_LastRowNo(1)
' Plot graphs
top = G_TOP
G_WIDTH = startRow2 * 18
'Call CreateGraph1(ser_data, "Chart1", top, CHART1_TITLE)
'top = top + G_HEIGHT + 50
'Call CreateGraph1(fat_data, "Chart2", top, CHART2_TITLE)
'Call NormalizeRange("Chart1", "Chart2", 1)
Call Get_Sheet(CHART_SHEET, True)
'top = top + G_HEIGHT + 50
Call CreateGraph2(ser_data, "Chart3", top, CHART3_TITLE)
top = top + G_HEIGHT + 50
Call CreateGraph2(fat_data, "Chart4", top, CHART4_TITLE)
Call NormalizeRange("Chart3", "Chart4", 1)
Call AlignAxes("Chart3")
Call AlignAxes("Chart4")
'Call NormalizeRange("Chart3", "Chart4", 2)
Application.CutCopyMode = False
ActiveSheet.Range("A1").Select
End Sub
Private Sub CreateGraph1(ByRef var As Variant, ByVal chartName As String, ByVal gTop As Integer, ByVal title As String)
Dim startRow As Integer, endRow As Integer
Dim startCol As Integer, endCol As Integer
Dim srcRange As Range
Dim chartObj As Chart
Dim ws As Worksheet
startRow = var(0)
startCol = var(1)
endRow = var(2) - 1
endCol = var(3) - 2
Sheets(SER_FAT_PLOT_SHEET).Activate
Set srcRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol))
Sheets(CHART_SHEET).Activate
Set ws = ActiveSheet
With ws.ChartObjects.Add(Left:=G_LEFT, Width:=G_WIDTH, top:=gTop, Height:=G_HEIGHT)
.name = chartName
With .Chart
.SetSourceData Source:=srcRange
.ChartType = xlColumnClustered
.ChartStyle = 2
.HasTitle = True
.ChartTitle.text = title
.ChartTitle.Font.Size = 14
.HasLegend = True
.Legend.Position = xlBottom
With .Legend.Border
.LineStyle = xlContinuous
.Weight = xlMedium
.Color = RGB(255, 153, 51)
End With
End With
End With
Set chartObj = ws.ChartObjects(chartName).Chart
With chartObj.ChartGroups(1)
.Overlap = 0
.GapWidth = 50
End With
' X-axis
With chartObj.Axes(xlCategory)
.TickLabels.Orientation = xlTickLabelOrientationUpward
.TickLabelPosition = xlTickLabelPositionLow
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(204, 204, 204)
End With
seriesCount = chartObj.SeriesCollection.count
For i = 1 To seriesCount
With chartObj.SeriesCollection(i)
.ChartType = xlColumnClustered
.AxisGroup = xlPrimary
.Interior.Color = myColor1(i)
End With
Next i
' Y-axiz
With chartObj.Axes(xlValue)
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(204, 204, 204)
End With
End Sub
Private Sub CreateGraph2(ByRef var As Variant, ByVal chartName As String, ByVal gTop As Integer, ByVal title As String)
Dim startRow As Integer, endRow As Integer
Dim startCol As Integer, endCol As Integer
Dim srcRange As Range
Dim chartObj As Chart
Dim ws As Worksheet
startRow = var(0)
startCol = var(1)
endRow = var(2) - 1
endCol = var(3)
Sheets(SER_FAT_PLOT_SHEET).Activate
Set srcRange = Range(Cells(startRow, startCol), Cells(endRow, endCol))
Sheets(CHART_SHEET).Activate
Set ws = ActiveSheet
With ws.ChartObjects.Add(Left:=G_LEFT, Width:=G_WIDTH, top:=gTop, Height:=G_HEIGHT)
.name = chartName
With .Chart
.SetSourceData Source:=srcRange
.ChartType = xlColumnClustered
.ChartStyle = 2
.HasTitle = True
.ChartTitle.text = title
.ChartTitle.Font.Size = 14
.HasLegend = True
.Legend.Position = xlBottom
With .Legend.Border
.LineStyle = xlContinuous
.Weight = xlMedium
.Color = RGB(255, 153, 51)
End With
End With
End With
Set chartObj = ws.ChartObjects(chartName).Chart
With chartObj.ChartGroups(1)
.Overlap = 0
.GapWidth = 50
End With
' X-axis
With chartObj.Axes(xlCategory)
.TickLabels.Orientation = xlTickLabelOrientationUpward
.TickLabelPosition = xlTickLabelPositionLow
.AxisBetweenCategories = False
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(204, 204, 204)
End With
seriesCount = chartObj.SeriesCollection.count
For i = 1 To seriesCount - 2
With chartObj.SeriesCollection(i)
.ChartType = xlColumnClustered
.AxisGroup = xlPrimary
.Interior.Color = myColor2(i)
End With
Next i
chartObj.HasAxis(xlValue, xlSecondary) = True
For i = seriesCount - 1 To seriesCount
With chartObj.SeriesCollection(i)
.ChartType = xlLineMarkers
.AxisGroup = xlSecondary
.MarkerSize = 5
.MarkerStyle = xlMarkerStylePlus
.Format.Line.DashStyle = msoLineSysDash
.Format.Line.Weight = 1
.Interior.Color = myColor2(13)
End With
Next i
chartObj.SeriesCollection(seriesCount).Format.Line.DashStyle = msoLineSysDot
chartObj.SeriesCollection(seriesCount).Interior.Color = myColor2(14)
chartObj.SeriesCollection(seriesCount).MarkerStyle = xlMarkerStyleDiamond
' Y-axiz
With chartObj.Axes(xlValue)
.HasMajorGridlines = True
.MajorGridlines.Border.Color = RGB(204, 204, 204)
End With
ws.ChartObjects(chartName).Visible = True
End Sub
Private Sub AlignAxes(ByVal chartName As String)
Dim Y1min As Double
Dim Y1max As Double
Dim Y2min As Double
Dim Y2max As Double
Dim chartObj As Chart
Dim ws As Worksheet
Set ws = ActiveSheet
Set chartObj = ws.ChartObjects(chartName).Chart
With chartObj
With .Axes(2, 1)
Y1min = .MinimumScale
Y1max = .MaximumScale
.MinimumScaleIsAuto = False
.MaximumScaleIsAuto = False
End With
With .Axes(2, 2)
Y2min = .MinimumScale
Y2max = .MaximumScale
.MinimumScaleIsAuto = False
.MaximumScaleIsAuto = False
.TickLabels.NumberFormat = "0.0#"
End With
If Y1max <> 0 Then
.Axes(2, 2).MinimumScale = Y1min * Y2max / Y1max
End If
End With
End Sub
Private Sub NormalizeRange(ByVal chartName1 As String, ByVal chartName2 As String, ByVal axisNo As Integer)
Dim chart1 As Chart, chart2 As Chart
Dim Ymin As Double, Ymax As Double
Dim ws As Worksheet
Set ws = ActiveSheet
Set chart1 = ws.ChartObjects(chartName1).Chart
Set chart2 = ws.ChartObjects(chartName2).Chart
If chart1.Axes(2, axisNo).MinimumScale < chart2.Axes(2, axisNo).MinimumScale Then
Ymin = chart1.Axes(2, axisNo).MinimumScale
Else
Ymin = chart2.Axes(2, axisNo).MinimumScale
End If
If chart1.Axes(2, axisNo).MaximumScale > chart2.Axes(2, axisNo).MaximumScale Then
Ymax = chart1.Axes(2, axisNo).MaximumScale
Else
Ymax = chart2.Axes(2, axisNo).MaximumScale
End If
With chart1.Axes(2, axisNo)
.MinimumScaleIsAuto = False
.MaximumScaleIsAuto = False
.MinimumScale = Ymin
.MaximumScale = Ymax
End With
With chart2.Axes(2, axisNo)
.MinimumScaleIsAuto = False
.MaximumScaleIsAuto = False
.MinimumScale = Ymin
.MaximumScale = Ymax
End With
End Sub
Private Sub CopyInParts(ByVal srcSheet As String, ByRef srcRange As Range, ByVal destSheet As String, ByRef destRange As Range)
Dim srcWs As Worksheet
Dim destWs As Worksheet
Dim rng As Range
Dim destStartRow As Long, rowStart As Long, rowEnd As Long
rowStart = srcRange.Row
rowEnd = srcRange.Rows.count + rowStart - 1
colStart = srcRange.Column
colEnd = srcRange.Columns.count + colStart - 1
destStartRow = destRange.Row
increment = INCREMENT_ROWS
Set srcWs = Sheets(srcSheet)
Set destWs = Sheets(destSheet)
While rowStart < rowEnd
If srcWs.Cells(rowStart, colStart).value = "" Then
GoTo CopyPart
End If
If rowStart + increment > rowEnd Then
GoTo CopyPart
End If
If rowStart + increment = rowEnd Then
dsr = rowStart + increment
Else
dsr = rowStart + increment - 1
End If
Set rng = srcWs.Range(srcWs.Cells(rowStart, colStart), srcWs.Cells(dsr, colEnd))
rng.Copy Destination:=destWs.Range("A" & destStartRow)
rowStart = rowStart + increment
destStartRow = destStartRow + increment
Application.CutCopyMode = False
Wend
CopyPart:
If rowStart <= rowEnd And srcWs.Cells(rowStart, colStart).value <> "" Then
Set rng = srcWs.Range(srcWs.Cells(rowStart, colStart), srcWs.Cells(rowEnd, colEnd))
rng.Copy Destination:=destWs.Range("A" & destStartRow)
Application.CutCopyMode = False
End If
End Sub
Private Sub CopyInPartsSpecial(ByVal srcSheet As String, ByRef srcRange As Range, ByVal destSheet As String)
Dim destWs As Worksheet
Dim rng As Range, area As Range
Set destWs = Sheets(destSheet)
For Each area In srcRange.Areas
rowNo = destWs.UsedRange.Rows.count
If rowNo = 1 And destWs.Cells(1, 1).value = "" Then
rowNo = 1
Else
rowNo = rowNo + 1
End If
Set rng = destWs.Range("A" & rowNo)
Call CopyInParts(srcSheet, area, destSheet, rng)
Next area
End Sub
Private Sub FillGaps(ByVal src As String, ByVal dest As String, ByRef destVars As Variant)
' destvars = [startRow, startCol, endRow, endCol]
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim srcRange As Range
Dim sortedRange As Range
Dim destRange As Range
Set srcSheet = Sheets(src)
Set destSheet = Sheets(dest)
srcSheet.Activate
lastRow = Get_LastRowNo(1)
colNo = Search_ColumnWithTitle(COUNTY_CITY_COL, "")
Set srcRange = srcSheet.Range(srcSheet.Cells(2, colNo), srcSheet.Cells(lastRow, colNo))
Set sortedRange = srcSheet.Range(srcSheet.Cells(2, colNo + 1), srcSheet.Cells(lastRow, colNo + 1))
srcRange.Copy Destination:=srcSheet.Cells(2, colNo + 1)
'sortedRange.RemoveDuplicates Columns:=(colNo + 1), Header:=xlNo
sortedRange.RemoveDuplicates Columns:=1, Header:=xlNo
sortedRange.Sort Key1:=sortedRange, Order1:=xlAscending
destSheet.Activate
destRow = destVars(0) + 1
Set destRange = destSheet.Range(destSheet.Cells(destRow, 1), destSheet.Cells(destRow, destVars(3)))
For srcRow = 2 To lastRow
ccName = srcSheet.Cells(srcRow, colNo + 1).value
If ccName = "" Then
Exit For
End If
If destSheet.Cells(destRow, 1).text <> ccName Then
destRange.Insert Shift:=xlDown
destSheet.Cells(destRow, 1).value = ccName
destSheet.Cells(destRow, destVars(1)).value = ccName
For i = destVars(1) + 1 To destVars(3)
destSheet.Cells(destRow, i).value = "0"
Next i
Else
Set destRange = destRange.Offset(1, 0)
End If
destRow = destRange.Row
Next srcRow
sortedRange.ClearContents
End Sub
Last edited by a moderator:
