TrinColll
06-19-2013, 01:22 PM
Hi I am an intern at a small tech start-up. The start-up asked me to develop an excel app that tracks training requirements for the company. I didn't know vba or excel formulas so everything I've coded I have learnt in the past 2 weeks, so things may be a little rough. The sheet has a data entry page where the employees name, training, training version, and date are inserted. There is then an employee spreadsheet, where employees are added and information about whether they are currently employed and what department they are in is tracked. If they no longer work for the company an inactive tag is added to all their entries in the Data entry worksheet. There are then Dashboard worksheets for each department that track the dates that employees completed their required SOPs for their department. I have utilized a combination of vba functions and subs as well as excel formulas to populate the sheets. I also needed to make the app dynamic, so I created many dynamic named ranges to allow for new data to be entered. The end result works however it is painfully slow and almost unusable. I am going to post some of my code that I think can and should be optimized.
I am sure I could make this function faster but I don't think its the main cause of the slowness
Sub PopulateDash()
Application.ScreenUpdating = False
Dim IT As Variant
ReDim IT(1) As Variant
Dim RD As Variant
ReDim RD(1) As Variant
Dim QA As Variant
ReDim QA(1) As Variant
Dim QC As Variant
ReDim QC(1) As Variant
Dim Test As Variant
ReDim Test(1) As Variant
Dim Dev As Variant
ReDim Dev(1) As Variant
Dim PM As Variant
ReDim PM(1) As Variant
Dim Admin As Variant
ReDim Admin(1) As Variant
Dim HD As Variant
ReDim HD(1) As Variant
With Sheets("SOP REQUIREMENTS")
For Each cel In [SopReqsYN]
If cel.Value = "Y" Then
Select Case cel.row
Case 2: IT(UBound(IT)) = .Cells(1, cel.Column).Value
ReDim Preserve IT(UBound(IT) + 1)
Case 3: RD(UBound(RD)) = .Cells(1, cel.Column).Value
ReDim Preserve RD(UBound(RD) + 1)
Case 4: QA(UBound(QA)) = .Cells(1, cel.Column).Value
ReDim Preserve QA(UBound(QA) + 1)
Case 5: QC(UBound(QC)) = .Cells(1, cel.Column).Value
ReDim Preserve QC(UBound(QC) + 1)
Case 6: Test(UBound(Test)) = .Cells(1, cel.Column).Value
ReDim Preserve Test(UBound(Test) + 1)
Case 7: Dev(UBound(Dev)) = .Cells(1, cel.Column).Value
ReDim Preserve Dev(UBound(Dev) + 1)
Case 8: PM(UBound(PM)) = .Cells(1, cel.Column).Value
ReDim Preserve PM(UBound(PM) + 1)
Case 9: Admin(UBound(Admin)) = .Cells(1, cel.Column).Value
ReDim Preserve Admin(UBound(Admin) + 1)
Case 10: HD(UBound(HD)) = .Cells(1, cel.Column).Value
ReDim Preserve HD(UBound(HD) + 1)
End Select
End If
Next
End With
[ITsop].ClearContents
[RDSop].Cells.ClearContents
[QASop].ClearContents
[QCSop].ClearContents
[TestSop].ClearContents
[DevSop].ClearContents
[PMSop].ClearContents
[AdminSop].ClearContents
[HDSop].ClearContents
Sheets("IT DASH").Range("A1").Resize(1, UBound(IT)) = IT
Sheets("RD DASH").Range("A1").Resize(1, UBound(RD)) = RD
Sheets("QA DASH").Range("A1").Resize(1, UBound(QA)) = QA
Sheets("QC DASH").Range("A1").Resize(1, UBound(QC)) = QC
Sheets("Test DASH").Range("A1").Resize(1, UBound(Test)) = Test
Sheets("Dev DASH").Range("A1").Resize(1, UBound(Dev)) = Dev
Sheets("PM DASH").Range("A1").Resize(1, UBound(PM)) = PM
Sheets("Admin DASH").Range("A1").Resize(1, UBound(Admin)) = Admin
Sheets("HD DASH").Range("A1").Resize(1, UBound(HD)) = HD
Application.ScreenUpdating = True
End Sub
I think this is the main problem as it is a function that i placed in the dashboard cells. It finds the most recent date.
Function PopulateDates(cell, DERange, sheet)
Dim SOPVersion As Variant
ReDim SOPVersion(1) As Variant
Dim SOPDate As Variant
ReDim SOPDate(1) As Variant
Dim SOPMaxDate As Variant
ReDim SOPMaxDate(1) As Variant
Dim x As Range
colu = cell.Column
row = cell.row
dashsop = Worksheets(sheet).Cells(1, colu).Value
Name = Worksheets(sheet).Cells(row, 1).Value
For Each cel In DERange
If dashsop = cel.Value And Name = cel.Offset(0, -1) Then
'MsgBox "Name: " & Name & " " & cel
SOPVersion(UBound(SOPVersion)) = cel.Offset(0, 2).Value
SOPDate(UBound(SOPDate)) = cel.Offset(0, 4).Value
ReDim Preserve SOPVersion(UBound(SOPVersion) + 1)
ReDim Preserve SOPDate(UBound(SOPDate) + 1)
End If
Next
ReDim Preserve SOPVersion(UBound(SOPVersion) - 1)
ReDim Preserve SOPDate(UBound(SOPDate) - 1)
Max = WorksheetFunction.Max(SOPVersion)
If UBound(SOPVersion) = 0 Then
PopulateDates = "N/A"
ElseIf UBound(SOPVersion) = 1 Then
PopulateDates = SOPDate(1)
ElseIf CountArray(SOPVersion, Max) = 1 Then
PopulateDates = SOPDate(Application.Match(Max, SOPVersion, False) - 1)
Else
For i = 1 To UBound(SOPVersion)
If SOPVersion(i) = Max Then
SOPMaxDate(UBound(SOPMaxDate)) = SOPDate(i)
ReDim Preserve SOPMaxDate(UBound(SOPMaxDate) + 1)
End If
Next i
ReDim Preserve SOPMaxDate(UBound(SOPMaxDate) - 1)
maxdate = 0
For Each dat In SOPMaxDate
If dat > maxdate Then
maxdate = dat
End If
Next
PopulateDates = maxdate
End If
Application.Calculate
End Function
Here is the function CountArray which counts the number of times a value appears in an array
Function CountArray(myArray, search)
Dim dict As Object
Dim i As Long, v As Variant
Set dict = CreateObject("Scripting.Dictionary")
dict.Add search, 0
For i = LBound(myArray) To UBound(myArray)
If myArray(i) = search Then
dict.Item(search) = dict.Item(search) + 1
End If
Next
CountArray = dict.Item(search)
End Function
If you need any help understanding what my code is trying to do let me know! It works the way I want it to it is just incredibly inefficient. Any Ideas would be greatly appreciated
Cheers :beerchug:
I am sure I could make this function faster but I don't think its the main cause of the slowness
Sub PopulateDash()
Application.ScreenUpdating = False
Dim IT As Variant
ReDim IT(1) As Variant
Dim RD As Variant
ReDim RD(1) As Variant
Dim QA As Variant
ReDim QA(1) As Variant
Dim QC As Variant
ReDim QC(1) As Variant
Dim Test As Variant
ReDim Test(1) As Variant
Dim Dev As Variant
ReDim Dev(1) As Variant
Dim PM As Variant
ReDim PM(1) As Variant
Dim Admin As Variant
ReDim Admin(1) As Variant
Dim HD As Variant
ReDim HD(1) As Variant
With Sheets("SOP REQUIREMENTS")
For Each cel In [SopReqsYN]
If cel.Value = "Y" Then
Select Case cel.row
Case 2: IT(UBound(IT)) = .Cells(1, cel.Column).Value
ReDim Preserve IT(UBound(IT) + 1)
Case 3: RD(UBound(RD)) = .Cells(1, cel.Column).Value
ReDim Preserve RD(UBound(RD) + 1)
Case 4: QA(UBound(QA)) = .Cells(1, cel.Column).Value
ReDim Preserve QA(UBound(QA) + 1)
Case 5: QC(UBound(QC)) = .Cells(1, cel.Column).Value
ReDim Preserve QC(UBound(QC) + 1)
Case 6: Test(UBound(Test)) = .Cells(1, cel.Column).Value
ReDim Preserve Test(UBound(Test) + 1)
Case 7: Dev(UBound(Dev)) = .Cells(1, cel.Column).Value
ReDim Preserve Dev(UBound(Dev) + 1)
Case 8: PM(UBound(PM)) = .Cells(1, cel.Column).Value
ReDim Preserve PM(UBound(PM) + 1)
Case 9: Admin(UBound(Admin)) = .Cells(1, cel.Column).Value
ReDim Preserve Admin(UBound(Admin) + 1)
Case 10: HD(UBound(HD)) = .Cells(1, cel.Column).Value
ReDim Preserve HD(UBound(HD) + 1)
End Select
End If
Next
End With
[ITsop].ClearContents
[RDSop].Cells.ClearContents
[QASop].ClearContents
[QCSop].ClearContents
[TestSop].ClearContents
[DevSop].ClearContents
[PMSop].ClearContents
[AdminSop].ClearContents
[HDSop].ClearContents
Sheets("IT DASH").Range("A1").Resize(1, UBound(IT)) = IT
Sheets("RD DASH").Range("A1").Resize(1, UBound(RD)) = RD
Sheets("QA DASH").Range("A1").Resize(1, UBound(QA)) = QA
Sheets("QC DASH").Range("A1").Resize(1, UBound(QC)) = QC
Sheets("Test DASH").Range("A1").Resize(1, UBound(Test)) = Test
Sheets("Dev DASH").Range("A1").Resize(1, UBound(Dev)) = Dev
Sheets("PM DASH").Range("A1").Resize(1, UBound(PM)) = PM
Sheets("Admin DASH").Range("A1").Resize(1, UBound(Admin)) = Admin
Sheets("HD DASH").Range("A1").Resize(1, UBound(HD)) = HD
Application.ScreenUpdating = True
End Sub
I think this is the main problem as it is a function that i placed in the dashboard cells. It finds the most recent date.
Function PopulateDates(cell, DERange, sheet)
Dim SOPVersion As Variant
ReDim SOPVersion(1) As Variant
Dim SOPDate As Variant
ReDim SOPDate(1) As Variant
Dim SOPMaxDate As Variant
ReDim SOPMaxDate(1) As Variant
Dim x As Range
colu = cell.Column
row = cell.row
dashsop = Worksheets(sheet).Cells(1, colu).Value
Name = Worksheets(sheet).Cells(row, 1).Value
For Each cel In DERange
If dashsop = cel.Value And Name = cel.Offset(0, -1) Then
'MsgBox "Name: " & Name & " " & cel
SOPVersion(UBound(SOPVersion)) = cel.Offset(0, 2).Value
SOPDate(UBound(SOPDate)) = cel.Offset(0, 4).Value
ReDim Preserve SOPVersion(UBound(SOPVersion) + 1)
ReDim Preserve SOPDate(UBound(SOPDate) + 1)
End If
Next
ReDim Preserve SOPVersion(UBound(SOPVersion) - 1)
ReDim Preserve SOPDate(UBound(SOPDate) - 1)
Max = WorksheetFunction.Max(SOPVersion)
If UBound(SOPVersion) = 0 Then
PopulateDates = "N/A"
ElseIf UBound(SOPVersion) = 1 Then
PopulateDates = SOPDate(1)
ElseIf CountArray(SOPVersion, Max) = 1 Then
PopulateDates = SOPDate(Application.Match(Max, SOPVersion, False) - 1)
Else
For i = 1 To UBound(SOPVersion)
If SOPVersion(i) = Max Then
SOPMaxDate(UBound(SOPMaxDate)) = SOPDate(i)
ReDim Preserve SOPMaxDate(UBound(SOPMaxDate) + 1)
End If
Next i
ReDim Preserve SOPMaxDate(UBound(SOPMaxDate) - 1)
maxdate = 0
For Each dat In SOPMaxDate
If dat > maxdate Then
maxdate = dat
End If
Next
PopulateDates = maxdate
End If
Application.Calculate
End Function
Here is the function CountArray which counts the number of times a value appears in an array
Function CountArray(myArray, search)
Dim dict As Object
Dim i As Long, v As Variant
Set dict = CreateObject("Scripting.Dictionary")
dict.Add search, 0
For i = LBound(myArray) To UBound(myArray)
If myArray(i) = search Then
dict.Item(search) = dict.Item(search) + 1
End If
Next
CountArray = dict.Item(search)
End Function
If you need any help understanding what my code is trying to do let me know! It works the way I want it to it is just incredibly inefficient. Any Ideas would be greatly appreciated
Cheers :beerchug: