As a starting disclaimer I think I qualify as a script kiddie...
We run a continuing education school in a retirement community. I adapted the dormant project, J-Walk Enhanced Data Form, that allows us to enter course registration information derived from paper forms into an Excel workbook we are using as a database. It's an entry form that allows me to go over the 32 field limit. Everything works on the form. There are four buttons which fill or clear large subsets of checkboxes that indicating the registration state of the resident for the the 30 or so offerings we have every semester. The subsets are for all the evening events, just the evening lectures, just the evening musical performances or a fourth button to remove all the checkmarks previously checked on the form. There is a third category of daytime classes but unlike the evening events, practically none of our residents commit to all of the day courses, so it doesn't need a button to speed recording of registrations.
Anyway execution upon clicking on one of the buttons mentioned above takes between 5-10 seconds. I did some class, module and routine profiling and unless I misinterpreted the results, almost half the time comes from taking -1s (minus ones) written or cleared by the buttons in the worksheet and writing them to the form and the other half, comes from the checkmark making class itself, so the bottleneck might be the making or clearing of checks on the form. I also gleaned from here (a DoneEx owned website–see below) that maybe the button subroutines are not as efficient as they could be, because they use sheet activations and cell selection commands.
I am calling an optimization sub recommended on the page linked for turning off automatic calculation, screenupdating, enabling events and the like and I think that helps. I'm aware that turning off the optimization routine is not couched within error catching code and that is a real problem that needs fixing. If anyone wants to help with that, I would appreciate it mightily too!
Anyway below is the clear button code and the form update routine. The attached checkmark class I'm guessing is professionally written and may not be improvable, but I don't know . Any suggestions on how to speed up the code would be greatly appreciated. DoneEx XCell Compiler cuts the 10 second button executions to 2 seconds. I'm highly tempted to buy it, but it is about $50 more at $150 than I can justify to our treasurer.
Thanks in advance for any help anybody can offer.
Private Sub ClearButton_Click()
Dim benchmark As Double
benchmark = Timer
Dim numberOfEvents As Integer
Dim numberOfClasses As Integer
Dim numberOfOfferings As Integer
Dim lastRowNumber As Integer
Dim lastCellRange As Range
Dim lastCell As String
Dim rg As Range
Dim xRg As Range
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
'Set the message box to close after 10 seconds
AckTime = 1
Select Case InfoBox.Popup("Please wait. The checkboxes will be cleared shortly.", _
AckTime, "Please Wait", 0)
Case 1, -1
End Select
OptimizedMode True
Sheet36.Activate
lastRowNumber = LastRowColumn(Sheet36, "r") 'Finds the last used row of the Course and Attendance Sheet.
lastCell = "C" & lastRowNumber 'Constructs the address of the last cell in column C, othe columns could be used instead
Set lastCellRange = Range(lastCell) 'Turns that address string into a range which consists of a single cell.
numberOfClasses = ColorCount([lastCellRange], [C2:C50]) 'Uses the color count function to count how many cells in one column starting from the
'bottom are shaded the same color thus counting the number of courses
numberOfEvents = totalEventsAndCourses() - numberOfClasses - 7 'Figures out the number events by subracting the number of courses from
'MsgBox ("The Number of events is: " & numberOfEvents & ". The Total Events and Courses is: " & totalEventsAndCourses() & ". The Number of Classes is:" & numberOfClasses) 'the total number of events plus clasess.
numberOfOfferings = numberOfEvents + numberOfClasses
'MsgBox ("The Number of number of offerings is: " & numberOfOfferings & ".")
Sheet5.Activate 'Returns action to the database worksheet
ActiveCell.Offset(0, 10).Range("A1").Select 'Starts selection in the fourth cell, as the first three are used for the name, address and phone number
Set xRg = ActiveCell.Range(Cells(1, 1), Cells(1, numberOfOfferings))
Application.DisplayAlerts = False
For Each rg In xRg
With rg
Select Case .Value
Case Is = -1
.Value = 0
Case Is = 0
.Value = 0
End Select
End With
Next
ActiveCell.Offset(0, -10).Range("A1").Select
OptimizedMode False
Call UpdateForm
MsgBox Timer - benchmark
End Sub
Display More
Here's the probably offending form update sub:
Sub UpdateForm()
'This sub updates the fields in the form
Dim ctl As Control
Dim Col As Long
Dim CurrentCell As Range
Col = 0
On Error Resume Next
For Each ctl In Frame1.Controls
If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Or TypeName(ctl) = "CheckBox" Then
Col = Col + 1
Set CurrentCell = Cells(CurrentRecord + RowOffset, Col + ColumnOffset)
ctl = CurrentCell
If CurrentCell.PrefixCharacter = "'" Then ctl = "'" & ctl
'Check for True/False cells (they would appear as 0 or -1)
If Application.WorksheetFunction.IsLogical(CurrentCell) Then
ctl = CurrentCell.Text
End If
'Is the cell displaying an error value?
If Err <> 0 Then
ctl = CurrentCell.Text 'Display this if the cell has an error value
Err = 0
End If
'Date?
If IsDate(Cells(CurrentRecord + RowOffset, Col + ColumnOffset)) Then
ctl = CurrentCell.Text
End If
'Formula?
If Cells(CurrentRecord + RowOffset, Col + ColumnOffset).HasFormula Then
ctl = FormatCurrency(CurrentCell)
ctl.Enabled = False
ctl.BackColor = RGB(240, 240, 240)
Else
ctl.Enabled = True
ctl.BackColor = RGB(255, 255, 255)
End If
If Cells(CurrentRecord + RowOffset, Col + ColumnOffset).Column = 3 Then
ctl = Format(CurrentCell, "(000) 000-0000")
ctl.Enabled = True
ctl.BackColor = RGB(255, 255, 255)
End If
If Cells(CurrentRecord + RowOffset, Col + ColumnOffset).Column = 46 Then
ctl = FormatCurrency(CurrentCell)
ctl.Enabled = True
ctl.BackColor = RGB(255, 255, 255)
End If
End If
'If TypeName(ctl) = "TextBox" Then
'End If
Next ctl
LabelRecNum = Text(9) & " " & CurrentRecord & " " & Text(10) & " " & RecordCount
On Error GoTo 0
End Sub
Display More