Improve my code?

[lifeson]

I have created the attached holiday/event planner which I am quite proud of :cloud9: but feel free to pass constructive criticism :(
It uses a list view control to display events as icons for a selected date range.
It does not require the user to create a spreadsheet calendar, they just enter the start and end date of an event and then the list view creates the calendar so it does not need rebuilding/formatting each year.

It worked fine during testing and design but now I have added some real data it has slowed down a bit so I dont think the routine(s) are as efficient as they could be as it takes a while to build - especially if the search range is over say 90 days.

It works by first building the listview layout by adding the column headers based on the user sheet and then creates a row for each date in the search range.

Then, for each date row on the listview, it searches for an event for each person in each column (on the events sheet)

This is where I think it slows down:

Function evtType(chkDate As Long, eName As String) As String
Dim ws As Worksheet
Dim i As Long, r As Long
Dim evtStart As Long, evtEnd As Long
Dim id As String, evt As String
Dim msg As String
Set ws = ThisWorkbook.Worksheets("Events")
r = ws.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To r
With ws
id = .Cells(i, "A")
evt = .Cells(i, "B")
evtStart = .Cells(i, "C")
evtEnd = .Cells(i, "D")
End With
If chkDate >= evtStart And chkDate <= evtEnd And id = eName Then
'MsgBox "for: " & eName & chkDate & " is between " & evtStart & " and " & evtEnd
evtType = evt
Else
'evt = isHoliday(chkDate)
'outside of range
End If
Next i
End Function
And the more data I add the slower it will get.

You can see it is searching every row for to see if the date is between the start and end date and if it is is that event for the person named.

Is there a better way than If...Then...Else to loop through the list of events?

[lifeson]

Oh, to use it
On the user form click show results - best to show from 01/01/08 - 01/01/09 to get a full view
(It defaults to todays date and 90 days in advance)

Or, from the events tab select Show events and then as above.

[Demosthine]

Good Afternoon.

There are several fairly easy methods to slightly increase the speed of your code.

The first and most noticable delay in speed occurs because Excel is having to constantly updating the visual representation of your ListView Control. Running the code with this Control visible took 18 seconds on my system. By setting this Control's visibility to False decreased the processing time to 10 seconds. You'll have to change the end of your Results procedure to set it's visiblity to True.

The next thing that skimmed an additional second off of the processing was to set Application.Calculation = xlCalculationManual at the start of the procedure and back to xlCalculationAutomatic at the end.


Hope this helps you.
Scott

[lifeson]

Thanks for the tips Demosthine, they have helped speed it up a bit, but I still think there is room for improvement.
I am not sure the logic of searching all the data on the events list is the best way of updating the listview

[Demosthine]

Hey there.

I was hoping that would speed it up well enough because my next recommendation is a little more involved, but should be well worth it once the work is done. It will be noticably faster with the shorter date ranges, but you won't see any increase in speed for the long date ranges.

Using ADOX, you have the ability to query a Worksheet just like you do a Table in Access or SQL. In fact, you use identical terminology and objects.

If you check out this thread, I have provided two separate examples that should get you well on your way to filtering the records. This will give you a much smaller range of data to work through as you add them to your Form.

I have another idea that may or may not work using a temporary Range that gets filtered. I'll check out that idea in a little bit and let you know whether it works or not.

Let me know how this works for you.
Scott

[Paul_Hossler]

I modified your Sub Progress to

1. only update the screen every full percent change, instead of every record

2. used .Repaint instead of DoEvents

and it seems to run faster



Option Explicit

Public OldPct As Long
Sub Progress(pct As Double)
Dim width As Single
If Int(100 * pct) = OldPct Then Exit Sub
OldPct = Int(100 * pct)
width = 550 * pct
'MsgBox width
With frmEvents
.lblProgress.BackColor = vbBlue
.lblProgress.width = 0
.lblProgress.width = width
End With
frmEvents.lblInfo.Caption = "Progress: " & Format(pct, "0%")
frmEvents.Repaint
End Sub


Paul

[lifeson]

Hey there.

I was hoping that would speed it up well enough because my next recommendation is a little more involved, but should be well worth it once the work is done. It will be noticably faster with the shorter date ranges, but you won't see any increase in speed for the long date ranges.

Using ADOX, you have the ability to query a Worksheet just like you do a Table in Access or SQL. In fact, you use identical terminology and objects.

If you check out this thread, I have provided two separate examples that should get you well on your way to filtering the records. This will give you a much smaller range of data to work through as you add them to your Form.

I have another idea that may or may not work using a temporary Range that gets filtered. I'll check out that idea in a little bit and let you know whether it works or not.

Let me know how this works for you.
Scott

Hi Scott
I looked at your example but I get an error with the recordset


Dim rstResults As Recordset
In tools > references I have:
Missing! Active X Data Objects Recordset 6.0 library

So Using a similar example of code I use to extract data from an access database
I changed it to this


Private Sub QueryWorkSheet(SQL As String)
'changed this...
'dim resResults as Recordset
'to this...
Dim rstResults As Object
'and changed this...
'Set rstResults = New Recordset
'to this...
Set rstResults = CreateObject("ADODB.Recordset")


But now get an error here:


rstResults.Open SQL, strConnection, _
CursorTypeEnum.adOpenForwardOnly, _
LockTypeEnum.adLockReadOnly

[Demosthine]

Wow, you're just having all sorts of problems with this, aren't you? :banghead:

What version of Office are you using? If it is Office 2000 or before, you will probably have an early version of ActiveX Date Objects. Unselect the missing version and scroll down to the appropriate spot in your list of references. You'll probably find a Version 5.0. Select this one and things should work ok.

Now, for your second issue once you used CreateObject... Would you please post the Workbook. You didn't say what error you received when you ran it.

Scott

[lifeson]

I am using office 2000
The highest version of Data objects is 2.5:rotlaugh:

Here is your original workbook with the mods I have made and hopefully you will see the error
"Cant find project or library" with

CursorTypeEnum highlighted

[Bob Phillips]

Option Explicit

Const adOpenForwardOnly As Long = 0
Const adLockReadOnly As Long = 1

Private Sub UserForm_Activate()
Dim intCol As Integer
' Add all of the Fields to the ComboBox.
With Worksheets("Employees")
For intCol = 1 To .Range("A1").End(xlToRight).Column
cboField.AddItem .Range("A1").Offset(0, intCol - 1).Value
Next intCol
End With
' Add all of the available Conditions to the ComboBox.
With cboCondition
.AddItem "Equal To"
.AddItem "Not Equal To"
.AddItem "Greater Than"
.AddItem "Less Than"
.AddItem "Between"
End With
End Sub

Private Sub cboField_Change()
lblQuery.Caption = Build_Query
End Sub

Private Sub cboCondition_Change()
Dim strCondition As String
If cboCondition.Text <> "" Then _
strCondition = cboCondition.Text
Select Case strCondition
Case "Equal To", "Not Equal To", "Greater Than", "Less Than"
txtValue01.Width = _
(txtValue02.Left - txtValue01.Left) + _
txtValue02.Width
lblValue02.Visible = False
txtValue02.Visible = False
Case "Between"
txtValue01.Width = txtValue02.Width
lblValue02.Visible = True
txtValue02.Visible = True
Case Else
End Select
lblQuery.Caption = Build_Query
End Sub

Private Sub txtValue01_Change()
lblQuery.Caption = Build_Query
End Sub

Private Sub txtValue02_Change()
lblQuery.Caption = Build_Query
End Sub

Public Function Build_Query() As String
Dim strField As String
Dim strCondition As String
Dim strValue01 As String
Dim strValue02 As String
Dim strQuery As String
strField = cboField.Text
strCondition = cboCondition.Text
strValue01 = txtValue01.Text
strValue02 = txtValue02.Text
strQuery = "SELECT * FROM [Employees] WHERE "
If strField <> "" Then
If InStr(1, strField, " ", vbTextCompare) <> 0 Then
strField = "[" & strField & "]"
Else
strField = strField
End If
If strCondition <> "" Then
Select Case strCondition
Case "Equal To"
strQuery = strQuery & strField & " = '" & strValue01 & "'"
Case "Not Equal To"
strQuery = strQuery & strField & " <> '" & strValue01 & "'"
Case "Greater Than"
strQuery = strQuery & strField & " > '" & strValue01 & "'"
Case "Less Than"
strQuery = strQuery & strField & " < '" & strValue01 & "'"
Case "Between"
strQuery = strQuery & "(" & strField & " > '" & strValue01 & "' And " & _
strField & " < '" & strValue02 & "')"
Case Else
' Don't Update
End Select
Else
strQuery = strQuery & strField
End If
End If
Build_Query = strQuery
End Function

Private Sub QueryWorkSheet(SQL As String)
On Error GoTo ErrHandler
' Dim rstResults As Recordset
Dim rstResults As Object
Dim strConnection As String
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
'Set rstresults = New Recordset
Set rstResults = CreateObject("ADODB.Recordset")
'also tried
Set rstResults = CreateObject("ADO.Recordset")
rstResults.Open SQL, strConnection, adOpenForwardOnly, adLockReadOnly
With Worksheets("Query Results")
.UsedRange.Clear
.Range("A01").CopyFromRecordset rstResults
End With
ErrHandler:
Debug.Print Err.Description
Set rstResults = Nothing
End Sub


Private Sub cmdQuery_Click()
'Dim rstResults As Recordset
QueryWorkSheet (lblQuery.Caption)
Worksheets("Query Results").Select
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

[lifeson]

XLD
Thats stopped the error showing but I dont get any results on the results sheet?
You set the recordset twice in the code ( I have tried both ways with no luck)



Private Sub QueryWorkSheet(SQL As String)
On Error GoTo ErrHandler
' Dim rstResults As Recordset
Dim rstResults As Object
Dim strConnection As String
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
'Set rstresults = New Recordset
Set rstResults = CreateObject("ADODB.Recordset")
'also tried
Set rstResults = CreateObject("ADO.Recordset")
rstResults.Open SQL, strConnection, adOpenForwardOnly, adLockReadOnly
With Worksheets("Query Results")
.UsedRange.Clear
.Range("A01").CopyFromRecordset rstResults
End With
ErrHandler:
Debug.Print Err.Description
Set rstResults = Nothing
End Sub


Private Sub cmdQuery_Click()
'Dim rstResults As Recordset
QueryWorkSheet (lblQuery.Caption)
Worksheets("Query Results").Select
End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

[Bob Phillips]

I didn't check whether the code works or not (where is supposed to get the data from, itself?), I just made your code runnable.

[lifeson]

I didn't check whether the code works or not (where is supposed to get the data from, itself?), I just made your code runnable.

This is the workbook with your code added
In the immediate window it still says Can't create active X object

[Bob Phillips]

This worked fine for me



Private Sub QueryWorkSheet(SQL As String)
On Error GoTo ErrHandler
' Dim rstResults As Recordset
Dim rstResults As Object
Dim strConnection As String
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
'Set rstresults = New Recordset
Set rstResults = CreateObject("ADODB.Recordset")
rstResults.Open SQL, strConnection, adOpenForwardOnly, adLockReadOnly
With Worksheets("Query Results")
.UsedRange.Clear
.Range("A01").CopyFromRecordset rstResults
End With
ErrHandler:
Debug.Print Err.Description
Set rstResults = Nothing
End Sub

[lifeson]

XLD
Thanks for keep looking at this. :bug:
There must be some conflict in versions you and I are running as I still get no results

Trying to debug the errors/info are

Data type mismatch in criteria expression.

?SQL
SELECT * FROM [Employees] WHERE ([Employee ID] > '3' And [Employee ID] < '5')
?strconnection
Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\curtisi2\Desktop\VBA Projects\Code examples\QueryBuilder_XLD.xls;Extended Properties=Excel 8.0;

[Bob Phillips]

How did you build the And condition?

[Kenneth Hobs]

I haven't looked at your code closely. You might find something that you could use in this.

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub

[Kenneth Hobs]

I modified your routine a bit as shown below. It will work for the string lookup like FirstName but not for a number lookup such as 1 for the first field. You will need to modify your SQL string to handle that.

I also changed the output range to A1. Your routine appeared to be to A, zero,1.


Private Sub QueryWorkSheet(SQL As String)
Dim rstResults As Object, rsConn As Object
Dim strConnection As String
On Error GoTo ErrHandler
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties=Excel 8.0;"
'Set rstresults = New Recordset
Set rstResults = CreateObject("ADODB.Recordset")
Set rsConn = CreateObject("ADODB.Connection")
rsConn.Open strConnection
rstResults.Open SQL, rsConn, 0, 1, 1
With Worksheets("Query Results")
.UsedRange.Clear
.Range("A1").CopyFromRecordset rstResults
End With
ErrHandler:
Debug.Print Err.Description
Set rstResults = Nothing
End Sub

[Demosthine]

Hey there again.

First, I'm sorry it took this long to get back to you. Last night I had some interuptions including a drunk idiot pounding on my door at midnight because he thought someone was trying to kill him. Let's just say that took a few hours away from my sleep cycle. Ugh!


But, back to your question...

In Post #9, you explained where the error was once you converted the code to Late-Binding using CreateObject. I'm sorry I didn't catch it right away, but XLD did fix that for you. Whenever you are using CreateObject, you have to manually define any constants that are contained in that class, just as he did in Post #10. Or you can use the literal value like Ken did in Post #18. Either way should work for you.


Now for solving your problem in Post #15. When you execute the SQL Query, you are receiving a Type Mismatch because...

When the RecordSet is opened, each Column (or Field using Access terminology) is assigned a Data Type based on the very first Row. Column A is set as an Integer because the value is a 1: an Integer. Column B thru Column E is set as Text. Column F and Column G is set as a Data, etc.

When you are opening the RecordSet, you have to be mindful of what Data Type it will be. Since the Workbook wasn't meant to be a final solution, I didn't include this portion of error checking.

To fix it, you'll need to add a Variable that stores a prefix character and add that to the section in BuildQuery where you are updating the Query.



' If the Value is a Number, SQL does not require any sort
' of prefix and suffix; therefore this is an empty string.
If strValue01 Like "[0-9]" Then
strPrefix = ""
' If the Value is a Date, SQL requires a # before and after
' the Value.
ElseIf IsDate(strValue01) Then
strPrefix = "#"
' If the Value is a String, SQL requires a ' before and after
' the Value.
Else
strPrefix = "'"
End If
If strCondition <> "" Then


This should give you the correct prefix. Now we have to implement it into the subsequent code. Change each of the Case sub-statements in the Select Case to match the following:



strQuery = strQuery & strField & " = " & strPrefix & strValue01 & strPrefix & ""

Hopefully this gets you up and running again.
Scott

[lifeson]

Hi Scott,
I must say your replies are excellent and expalined fully.

I am still playing around with using SQL on the worksheet and at the moment it seems a bit hit and miss (which is probably my fault but I will persevere

Anyaway back to the original posting
I have managed to improve the speed dramatically (around 30%) by changing the search routine


I have narrowed the search range on the Events sheet by finding the first and last row dependant on the start and end date enetered on the userform using these

Function StartRow(sDate As Long, eDate As Long) As Long
Dim i As Long, r As Long
Dim rng As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Events")
r = ws.Cells(Rows.Count, "A").End(xlUp).Row
With ws
For i = 2 To r
chkDate = .Cells(i, "D")
If chkDate > sDate And chkDate < eDate Then
StartRow = i
Exit Function
Else
'look at next row
End If
Next i ' row
End With 'ws
End Function

Function LastRow(sDate As Long, eDate As Long) As Long
Dim i As Long, r As Long
Dim rng As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Events")
r = ws.Cells(Rows.Count, "A").End(xlUp).Row
With ws
For i = r To 2 Step -1
' MsgBox "Checking row " & i
chkDate = .Cells(i, "C")
If chkDate > sDate And chkDate < eDate Then
LastRow = i
Exit Function
Else
'look at next row
End If
Next i ' row
End With 'ws
End Function

and calling them using this

evt = evtType(serSdate, eName, fRow, lRow)

However I have a new problem :think: :think: :think:

When the form opens and you first click on 'Show Results' everything works fine:thumb .
But if you click the Show results button again the listview control moves to the top of the form and the only way to move it is to move the userform slightly

I have put code to re-positon the listview but that doesn't seem to have any effect
Any idea what causes this or how to get around it?

[Demosthine]

Hey there.

Unfortunately, after a lot of debugging (and I do mean a LOT), I can not find what is causing the error. It would appear that there is a bug in the ListView Control 6.0 where certain commands cause it to be repositioned incorrectly.

I have found that if the ListView is not visible, executing a ListItems.Clear or ListItems.Add, seems to cause the problem. What makes it more interesting is that once the control relocates to (0, 0), it still returns the correct value of 48 for it's .Top property.

The only thing I would recommend it finding out if there is a newer version of the control or keeping it as Visible. I was running ListView 6.0 (SP2), in case you want to compare versions.

I'll have my buddy Mark (GTO) look into it as well. He's really good at debugging and catching errors.

Let me know if you find another solution.
Scott

[GTO]

Greetings lifeson,

Though reference VB4, this article:

http://support.microsoft.com/kb/142468/en-us

...got me to thinking that maybe toggling the visibility might work. A bit sloppy, but it did work. I would note that before finding the article, I had tried the rem'd commands and these also worked (That is, specifying a 0/0 Top/Left before resetting to the desired position.).

I would also note that I changed the visibility to True at design time in the properties window. Works either way, but form looks better at start-up.

Hope this helps,

Mark


Private Sub FAKE_results()
'...Statements...
With frmEvents.lvwResults
.Visible = True
' DoEvents
.Visible = False
.View = lvwReport
.ListItems.Clear
.SmallIcons = frmEvents.ImageList1
.ColumnHeaderIcons = frmEvents.ImageList1
'...Statements...
'turn listview control back on and reposition
.Visible = True
.Visible = False
.Visible = True
'.Left = 0
'.Top = 0
'DoEvents
'.Left = 12.75
'.Top = 48
'DoEvents
End With 'lvw
'...Statements...
End Sub

[lifeson]

GTO & Demosthine
Thanks for looking at that :thumb :thumb
The only other solution I could find was to move the form slightly :eek: but your solution is much easier on the eye.

For reference
I improved the speed again further by usind 'find' for the dates on the holiday sheet as all the bank holidays only span 1 day there was no need to use a for... next loop to find the date


Function isHoliday(chkDate As Long) As String
Dim ws As Worksheet
Dim i As Long, evtStart As Long
Dim rng As Range, r As Range
Dim id As String, evt As String
Set ws = ThisWorkbook.Worksheets("Holidays")
Set rng = ws.Range("A:A")
With rng
Set r = .Find(chkDate)
If Not r Is Nothing Then
'MsgBox r.Address
isHoliday = r.Offset(0, 2).Value
Else
'MsgBox chkDate & " Not a Holiday"
isHoliday = ""
End If
End With
Set r = Nothing
Set rng = Nothing
End Function

[GTO]

The only other solution I could find was to move the form slightly :eek: but your solution is much easier on the eye.


Well thank you and I'm glad we were able to help. Kudos for finding another area to improve run speed in as well!

Mark