wackywoo105
Registered User.
- Local time
- Today, 00:38
- Joined
- Mar 14, 2014
- Messages
- 203
I use the following code to populate a list box with available appointments from an excel spreadsheet. The line within the spreadsheet it starts from is stored in a setting table and is updated by the code each time it runs, so it doesn’t go over past appointments. I also try to keep the excel spreadsheet short by deleting old appointments from it. I did all this to try and speed it up. Even so it still takes a while to populate the list box. I am wondering if there is anything anyone can suggest to make this process faster?
Code:
List29.RowSource = ""
Dim oXLApp As Excel.Application 'Declare the object variables
Dim oXLBook As Excel.Workbook
Dim oXLSheet As Excel.Worksheet
Set oXLApp = New Excel.Application 'Create a new instance of Excel
oXLApp.Visible = False
If Dir(setdrive & "Appointments.xls") = "" Then
MsgBox ("Appointments spreadsheet not found.")
GoTo appsheetmissing
Else
Set oXLBook = oXLApp.Workbooks.Open(setdrive & "Appointments.xls") 'Open an existing workbook
End If
Set oXLSheet = oXLBook.Worksheets(1)
Dim LastRow As Integer
LastRow = oXLSheet.UsedRange.Rows.count + 1
Dim startline As Integer 'code to ensure always starts from correct app sheet line
Dim startlinereached As Boolean
startlinereached = False
If appsheetlength < 9 Then appsheetlength = 9
For counter = appsheetlength To LastRow ' populate listbox with available apps
If oXLSheet.Cells(counter, 1).Value >= Date Then
If Not IsNull(oXLSheet.Cells(counter, 1).Value) And oXLSheet.Cells(counter, 2).Value <> "" And oXLSheet.Cells(counter, 3).Value = "" And oXLSheet.Cells(counter, 4).Value = "" And oXLSheet.Cells(counter, 5).Value = "" Then
If oXLSheet.Cells(counter, 1).Value Like "##/##/####" Then
If oXLSheet.Cells(counter, 2).Value Like "0.*" Then
item = Format(oXLSheet.Cells(counter, 1).Value, "ddd dd/mm/yyyy") & " at " & Format(oXLSheet.Cells(counter, 2).Value, "hh:mm AM/PM")
If startlinereached = False Then
startline = counter
startlinereached = True
End If
If oXLSheet.Cells(counter, 3).Interior.Color = RGB(192, 80, 77) Then item = item & " try to book last"
If oXLSheet.Cells(counter, 3).Interior.Color = RGB(192, 80, 77) Then item2 = "try to book last" Else item2 = ""
List29.AddItem (Format(oXLSheet.Cells(counter, 1).Value, "ddd dd/mm/yyyy") & ";" & Format(oXLSheet.Cells(counter, 2).Value, "hh:mm AM/PM") & ";" & item2)
End If
End If
End If
End If
Next counter
Dim sqls As String
startline = startline - 10
If startline < 9 Then startline = 9
sqls = "UPDATE [Settings] SET [AppSheetStartLine] = " & startline & " WHERE [ID] = 1;"
DoCmd.SetWarnings False
DoCmd.RunSQL sqls
DoCmd.SetWarnings True
oXLApp.DisplayAlerts = False
Set oXLSheet = Nothing
Set oXLBook = Nothing 'Disconnect from Excel (let the user take over)
oXLApp.Quit 'Close (and disconnect from) Excel
Set oXLApp = Nothing
If (Environ$("Username")) = "admin" Then 'In win 10 excel won't close so use shell
Call Shell("taskkill /f /im excel.exe")
End If
appsheetmissing: