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
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