Built my excel app but it's super slow

[TrinColll]

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:

[SamT]

ReDim - Preserve takes a lot of overhead. I think I figured out that SysReqsYN is a matrix with the requirements in the first row and the Depts(?) in the first column.

Option Explicit

Sub SamT()
Dim IT As Long
Dim RD As Long
Dim QA As Long
Dim QC As Long
Dim Test As Long
Dim Dev As Long
Dim PM As Long
Dim Admin As Long
Dim HD As Long

With Sheets("SOP REQUIREMENTS")
For Each Cel In [SopReqsYN]
If Cel.Value = "Y" Then
Select Case Cel.Row
Case 2: IT = IT + 1
Sheets("IT DASH").Cells(1, IT) = .Cells(1, Cel.Column).Value
Case 3: RD = RD + 1
Sheets("RD DASH").Cells(1, RD) = .Cells(1, Cel.Column).Value
Case 4: QA = QA + 1
Sheets("QA DASH").Cells(1, QA) = .Cells(1, Cel.Column).Value
Case 5: QC = QC + 1
Sheets("QC DASH").Cells(1, QC) = .Cells(1, Cel.Column).Value
Case 6: Test = Test + 1
Sheets("Test DASH").Cells(1, Test) = .Cells(1, Cel.Column).Value
Case 7: Dev = Dev + 1
Sheets("Dev DASH").Cells(1, Dev) = .Cells(1, Cel.Column).Value
Case 8: PM = PM + 1
Sheets("PM DASH").Cells(1, PM) = .Cells(1, Cel.Column).Value
Case 9: Admin = Admin + 1
Sheets("Admin DASH").Cells(1, Admin) = .Cells(1, Cel.Column).Value
Case 10: HD = HD + 1
Sheets("HD DASH").Cells(1, HD) = .Cells(1, Cel.Column).Value
End Select
End If
Next
End With

Range(Range(SopReqsYN).Rows(2), Range(SopReqsYN).Rows(10)).ClearContents

Application.ScreenUpdating = True

End Sub

[SamT]

I am looking at your PopulateDates function now, and :banghead:

The Variable type that uses the most memory is the default type, Variant. Every variable you use is a variant type because you don't declare them.

The method that takes the CPU cycles is the Redim-Preserve method. And that seems to be your favorite method of all of them.

Function PopulateDates(cell, DERange, sheet) Is the equivalent of
Function PopulateDates(cell As Variant, DERange as Variant, sheet As Variant) As Variant
And there is the problem that your variables, "Cell," "Sheet," "Row," "Max," and "Name," are keywords in VBA and Excel, causing even more time to be used while the compiler runs through the code over and over trying to resolve all the possiblities.

Do yourself a favor and go to the VBA Menu >> Tool >> Options >> Editor Tab and check all the boxes in the Code Settings group.

Some common Variable names I use are Col, Rw, Rng and Cel, Sht, WkSht, and ChrtSht, Bk and WkBk.

If you rewrite the function declaration as
Function PopulateDates(dashsop As String, SOPName As String, DERange As Range) As Variant
'SOPName Replaces Name

and get those values in the calling procedure, where you should and then pass them to the function you can get rid of

colu = cell.Column
Row = cell.Row
dashsop = Worksheets(sheet).Cells(1, colu).Value
Name = Worksheets(sheet).Cells(Row, 1).Value
in the function.

You have 6 Redim-Preserves in that function. You can get rid of all of them by
Dim MaxCount As Long
MaxCount = DERange.Rows.Count
Dim SOPVersion As Variant
ReDim SOPVersion(MaxCount) As Variant

Dim SOPDate As Variant
ReDim SOPDate(MaxCount) As Variant 'Probably As Double

Dim SOPMaxDate As Variant
ReDim SOPMaxDate(MaxCount) As Variant 'Probably As Double
You even Resdim-Preserve them back 1 notch just before you're done with them.:dunno

Since you are only looking for a maximum valuer, any empty slots in the arrays will be ignored. Who cares how big they are?

[SamT]

I'm going thru your loop now, trying to see exactly what you're doing.

Since you can reasonably expect no, or only one instance of "dashop" this very fast nested IF at the very top of the function will check for that and prevent the rest of the function from running if appropriate.

Function PopulateDates(dashsop As String, SOPName As String, DERange As Range) As Variant

Dim Result As Range
Result = DERange.Find(dashsop)
If Result Is Nothing Then 'If not found, we're done.
PopulateDates = "N/A"
Exit Function

Else 'We found at least 1
PopulateDates = Result.Offset(0, 4).Value

If Not FindNext Is Nothing Then 'If there's 2 instances, continue with Function.
PopulateDates = ""
Else 'There's only 1, we're done.
Exit Function
End If

End If

Dim 'Blah, blah, blah

[SamT]

OK, try this. It provides the latest date of the latest version.
Dim Result As Range
Result = DERange.Find(dashsop)
If Result Is Nothing Then 'If not found, we're done.
PopulateDates = "N/A"
Exit Function

Else 'We found at least 1
PopulateDates = Result.Offset(0, 4).Value

If Not FindNext Is Nothing Then 'If there's 2 instances, continue with Function.
PopulateDates = ""
Else 'There's only 1, we're done.
Exit Function
End If

End If

Dim MaxVersion As String
Dim MaxDate As Double

For Each Cel In DERange
If dashsop = Cel.Value Then
If SOPName = Cel.Offset(0, -1) Then
'Tracking MaxVersion
If Cel.Offset(0, 2).Value > MaxVersion Then 'Get the Date
MaxVersion = Cel.Offset(0, 2).Value
MaxDate = Cel.Offset(0, 4).Value
Else 'Current Cel Version not Max
GoTo NextCel
'Else if Version = Max
ElseIf Cel.Offset(0, 4).Value > MaxDate Then 'Current Cel Date is newer
MaxDate = Cel.Offset(0, 4).Value 'Get the Latest Date
End If
End If
End If
NextCel:
Next
PopulateDates = MaxDate

Application.Calculate
End Function

[SamT]

Function CountArray(myArray, search) As Long
Dim i As Long, SrchCount As Long

For i = LBound(myArray) To UBound(myArray)
If myArray(i) = search Then
SrchCount = SrchCount + 1
End If
Next
CountArray = SrchCount
End Function

[Paul_Hossler]

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.


Does this really need to be worksheet function?

If you have VBA determine it using the right Change event, and just put the value where you wanted it on the dashboard, it would seem that a lot of re-calculation would be eliminated

It'd be useful to see a small sample WB with the results of SamT's suggestions

Paul