Select cells with same value with variable - vba

Let's assume I have in xls a range filled like this:
ROW 1 |1|s|d|f|g|
ROW 2 |2|d|k|o|p|
ROW 3 |1|a|x|y|z|
I already have the code (vba) to work (parse data) on each row and put it into a txt file, but I'm not able to work only with rows that have, for example, "1" in the first column.
Almost tried most of the suggestion here posted without any luck...
Private Sub CommandButton1_Click()
lastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
SetValSrcNat = ""
Set fs = CreateObject("Scripting.FileSystemObject")
On Error GoTo fileexists
Set stream = fs.CreateTextFile("C:\Users\luciano.vigano\Documents \prova.txt", False, True)
For elabrow = 6 To lastRow
valInterface = Cells(elabrow, 3).Value
valProto = Cells(elabrow, 8).Value
valSrc = Cells(elabrow, 9).Value
If valSrc = "host" Then
valSrc = Cells(elabrow, 10)
Else
valSrc = Cells(elabrow, 9).Value & " " & Cells(elabrow, 10)
End If
valSrcNat = Cells(elabrow, 11).Value
If valSrcNat = "" Then
valSrcNat = SetValSrcNat
Else
valSrcNat = Cells(elabrow, 11).Value
End If
stream.Write ("Rule" & valRuleNumber & Chr(13) & Chr(10))
stream.WriteLine valInterface
Next elabrow
stream.Close
fileexists:
If Err.Number = 58 Then
MsgBox "File already Exists"
End If
End Sub

Related

VBA Runtime 91 Error

Trying to automate a lengthy data entry process in excel.
For some reason the second time I try to find a value in a given range I get a run time 91 error. I can't figure out why this is happening. If I change the range from "AF3:AF30" to the first time I set a range("B2:AD2"), the program will continue through the line with no problem. But for some reason any range other than the first "B2:AD2" will give runtime!
Code:
Sub AutoFill()
Range("B8:AD57").Select
Selection.ClearContents
Range("B8").Select
Dim Rng As Range, cell As Range
Set Rng = Worksheets("Avon Trailer List").Range("E4:E38")
For Each cell In Rng
Dim temp As String
temp = Replace(cell.Value(), " ", "")
temp = Replace(temp, "+", "")
If temp = "" Then
Exit For
Else
col = ""
tempa = SplitMultiDelims(temp, "/,\)(")
For i = 0 To UBound(tempa)
If InStr(tempa(i), "A") = 1 Then
strInput = Worksheets("Pallet Check").Range("B2:AD2").Find(tempa(i)).Address()
lnRow = Range(strInput).Row
strCol = Left(strInput, Len(strInput) - Len(CStr(lnRow)))
strCol = Replace(strCol, "S", "")
Search = tempa(i)
ElseIf InStr(tempa(i), "A") > 1 Or InStr(tempa(i), "B") > 1 Or InStr(tempa(i), "a") > 1 Or InStr(tempa(i), "b") > 1 Then
strInput = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search).Address()
lnRow = Range(strInput).Row
Range("AH" & lnRow).Value() = "(" & tempa(i) & ")"
ElseIf tempa(i) <> "" Then
Worksheets("Pallet Check").Range(strCol & tempa(i) + 7).Value() = Worksheets("Pallet Check").Range(strCol & tempa(i) + 7).Value() & tempa(i)
End If
Next i
End If
Next cell
End Sub
Runtime Error 91 happens on the following line of code:
strInput = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search).Address()

Find().Address breaks with exception (code 91) if not found. This is because .Find() returns a range that actually points to one specific cell OR returns Nothing when not found and 'Nothing'.Address is meaningless (n.b.: null value for objects in VBA is 'Nothing'). So I would replace that line with
Fnd = Worksheets("Pallet Check").Range("AF3:AF30").Find(Search)
if Not Fnd Is Nothing then
strInput = Fnd.Address
...

Find out the cases having discrepancies

I am having a sheet having seven cloumns. First six columns having either true or false and in last column I have to mention the heading of false cases in one statement. Below is the excel.
Excel sheet
I have tried if else statement but there are too many possibilities. Since I am new to VBA i don't know any shortcut to that.Any suggestions?.... Thanks

Try this simple vba code,
Sub TEXTJOIN()
Dim i As Long, str As String, k As Long, j As Long
str = ""
j = 0
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.CountIf(Range("A" & i & ":F" & i), True) = 6 Then
Cells(i, 7) = "No Discrepancy Found"
Else
For k = 1 To 6
If Cells(i, k) = False Then
str = str & Cells(1, k) & ","
j = j + 1
End If
Next k
str = Left(str, Len(str) - 1) & " mismatch found"
Cells(i, 7) = Application.WorksheetFunction.Substitute(str, ",", " and ", j - 1)
str = ""
j = 0
End If
Next i
End Sub

Here's simple code which you should try:
Sub FindDiscrepancies()
Dim lastRow, i, j As Long
Dim discrepancies As String: discrepancies = ""
'find number of last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
For j = 1 To 6
If LCase(Cells(i, j).Value) = "false" Then
discrepancies = discrepancies & Cells(1, j).Value & ", "
End If
Next j
If discrepancies = "" Then
Cells(i, 7).Value = "No discrepancies found"
Else
Cells(i, 7).Value = "Mismatch found in " & discrepancies
End If
discrepancies = ""
Next i
End Sub

Finding last empty row not working for one sheet only

My mind is broken. I have spent days trying to figure out why this is happening:
After a user form is filled out there is a button to populate a corresponding spreadsheet. The sheet is determined by the first combo box (catSel.value). To find the last empty row I use the rngSrch portion of the code below.
On one sheet If Application.WorksheetFunction.CountA(Acell.EntireRow) = 0 comes back as false and firstBlankRow = Acell.row is not run.
I have tried deleting the sheet and creating a new one(copying one that works), changing the name and commenting out/changing the code.
Any ideas why this is happening? Also ws.Range("A" & firstBlankRow) = Me.equipId.value is coming back with Run-time Error ‘1004’: method ‘Range’ of object ’_worksheet’ failed
Private Sub AddCont_Click()
Dim firstBlankRow As Long
Dim ws As Worksheet
Dim srchRng As Range
Dim Acell As Range
Set ws = Worksheets(CatSel.value)
On Error GoTo Err
With ws
Set srchRng = .UsedRange.Columns(1).Find("")
If Not srchRng Is Nothing Then
Set srchRng =.UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
For Each Acell In srchRng
If Application.WorksheetFunction.CountA(Acell.EntireRow) = 0 Then
firstBlankRow = Acell.row
Exit For
End If
Next
Else
If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then
MsgBox "Please start a new sheet"
Else
firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).row + 1
End If
End If
'Equipment ID
ws.Range("A" & firstBlankRow) = Me.equipId.value
'Parent or Next Level
ws.Range("B" & firstBlankRow) = Me.NextLev.value
'Keyword
ws.Range("C" & firstBlankRow) = Me.KeySel.value
'Cost Center
ws.Range("E" & firstBlankRow) = Me.CostSel.value
'Department
ws.Range("F" & firstBlankRow) = Me.DepartSel.value
'Location 1
ws.Range("G" & firstBlankRow) = Me.Loc1.value
'Location 2
ws.Range("H" & firstBlankRow) = Me.Loc2.value
'Location 3
ws.Range("I" & firstBlankRow) = Me.Loc3.value
'Location 4
ws.Range("J" & firstBlankRow) = Me.Loc4.value
'Beginning of specs
'L5
ws.Range("L" & firstBlankRow) = Me.L3Sel.value
'M5
ws.Range("M" & firstBlankRow) = Me.M3Sel.value
'N5
ws.Range("N" & firstBlankRow) = Me.N3sel.value
'O5
ws.Range("O" & firstBlankRow) = Me.O3Sel.value
'P5
ws.Range("P" & firstBlankRow) = Me.P3Sel.value
'Q5
ws.Range("Q" & firstBlankRow) = Me.Q3Sel.value
'R5
ws.Range("R" & firstBlankRow) = Me.R3Sel.value
'S5
ws.Range("S" & firstBlankRow) = Me.S3Sel.value
'T5
ws.Range("T" & firstBlankRow) = Me.T3Sel.value
'U5
ws.Range("U" & firstBlankRow) = Me.U3Sel.value
MsgBox ("successfully Added")
End With
Err: MsgBox ("something went wrong")
End Sub

I think in this part of the code
Set srchRng = .UsedRange.Columns(1).Find("")
If Not srchRng Is Nothing Then
Set srchRng =.UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
For Each Acell In srchRng
If Application.WorksheetFunction.CountA(Acell.EntireRow) = 0 Then
firstBlankRow = Acell.row
Exit For
End If
Next
Else
If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then
MsgBox "Please start a new sheet"
Else
firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).row + 1
End If
End If
you are trying to find the first blank row, so that you can insert a new record.
If so, I suggest you replace that code with:
If IsEmpty(.Cells(.Rows.Count, 1)) Then
firstBlankRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Else
MsgBox "Please start a new sheet"
Exit Sub
End If
That code will look for the last non-empty cell in column A and set the firstBlankRow variable to point to the row after it.
If your records sometimes have an empty value in column A, but you have another column that can be guaranteed to always have a value, just change the above code to refer to that column instead of to column 1. E.g. (assuming column D is always populated):
If IsEmpty(.Cells(.Rows.Count, "D")) Then
firstBlankRow = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
Else
MsgBox "Please start a new sheet"
Exit Sub
End If
If you have records where no column is guaranteed to be non-empty, perhaps this code will work:
firstBlankRow = .Rows.Count + 1
If IsEmpty(.Cells(.Rows.Count, "A")) Then
For firstBlankRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 To .Rows.Count
If Application.WorksheetFunction.CountA(.Rows(firstBlankRow)) = 0 Then
Exit For
End If
Next
End If
If firstBlankRow = .Rows.Count + 1 Then
MsgBox "Please start a new sheet"
Exit Sub
End If

Windows Script to open Excel file and run macro

Sorry I am very new to VBA so am learning as I go along. I have tried to search for an answer to this but everything I find seems to think that the macro will be in the file I want to open.
Once a month I get a file that contains some data. Up to now I had to look at the data then do a VLOOKUP to add some additional data before saving it.
I have now written a VBA macro to add the additional information I want and it works as intended. However what I would like to do is have a Windows script that will open the file I receive, run the macro I have written, then save the file as a csv.
Can anyone point me in the right direction? If needed my macro is below
Sub AddBandInfo()
Dim i As Long
For i = 2 To 50000
Dim band As String, result As Double
band = Range("B" & i).Value
If band = "A" Then result = 1144.02
If band = "B" Then result = 1334.7
If band = "C" Then result = 1525.36
If band = "D" Then result = 1716.04
If band = "E" Then result = 2097.38
If band = "F" Then result = 2478.72
If band = "G" Then result = 2860.08
If band = "H" Then result = 3432.08
If band = "" Then result = 0.01
Range("C" & i).Value = result
Next i
Dim r As Long
For r = Sheet1.UsedRange.Rows.Count To 1 Step -1
If Cells(r, "C") = "0.01" Then
Sheet1.Rows(r).EntireRow.Delete
End If
Next
End Sub
Thanks

Create a .txt-file and rename it to .vbs.
Start your code with:
Set objXLS = CreateObject("Excel.Application")
Set myWkbk = objXLS.Application.Workbooks.Open("C:\mypath\myfile.xlsx")
Set myWksh = myWkbk.Worksheets("yoursheet")
With myWksh
'your
'code
'here
End With
Set objXLS = Nothing
All done. :)

We can improve AddBandInfo speed and performance by
Toggling Application.ScreenUpdating
Looping from the last row to the first row (doing this allows use to delete the rows as we go)
If 50000 isn't the actual last row use
For i = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
Public Sub AddBandInfo()
Dim i As Long
Application.ScreenUpdating = False
For i = 50000 To 2 Step -1
Dim band As String, result As Double
band = Range("B" & i).Value
Select Case Cells(i, 2).Value
Case "A"
Range("C" & i).Value = 1144.02
Case "B"
Range("C" & i).Value = 1334.7
Case "C"
Range("C" & i).Value = 1525.36
Case "D"
Range("C" & i).Value = 1716.04
Case "E"
Range("C" & i).Value = 2097.38
Case "F"
Range("C" & i).Value = 2478.72
Case "G"
Range("C" & i).Value = 2860.08
Case "H"
Range("C" & i).Value = 3432.08
Case Else
Rows(i).EntireRow.Delete
End Select
Next
Application.ScreenUpdating = True
End Sub
Assuming AddBandInfo is saved in C:\somedirectory\somefile.xlsx and that you want a vbscript to open the Workbook and then run AddBandInfo:
Const WorkBookPath = "C:\somedirectory\somefile.xlsx"
Dim xlApplication, xlWorkbook
Set xlApplication = CreateObject("Excel.Application")
Set xlWorkbook = xlApplication.Workbooks.Open(WorkBookPath)
xlApplication.Run "'" & xlWorkbook.Name & "'!AddBandInfo()"
xlWorkbook.Save , False
xlApplication.Quit
Set xlApplication = Nothing

Memory Leak in vba code

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