Hi All,
I have quite a bit of code which I am trying to now trying to error proof. I have set up a error counter to try and loop through the procedure of connecting to an Access database if the database is in use (admin locked). I thought this was working fine since I hadn't had an error since but today the same error has cropped up. Can someone check through that I have implemented this correctly.
The code is as follows:
I have quite a bit of code which I am trying to now trying to error proof. I have set up a error counter to try and loop through the procedure of connecting to an Access database if the database is in use (admin locked). I thought this was working fine since I hadn't had an error since but today the same error has cropped up. Can someone check through that I have implemented this correctly.
- The basic setup of the whole code is as follows:
- Calculate a date to be input in to a sql string.
- Connect to the database
- Select the records
- Import them in to excel
- Carry out some calculations
- The basic setup of the whole code is as follows:
- Calculate a date to be input in to a sql string.
- Connect to the database
- If error produced when trying to connect loop through the connection 5 times.
- If still unable to connect succesfully display an alert and continue with the rest of the procedures in the sheet.
- If the code connects fine, then skip the error handling and continue with calculations.
The code is as follows:
Code:
Sub GetTeamandStaff()
'Declare variables
Dim Db As Database
Dim RS As Recordset
Dim WS As Worksheet
Dim i As Integer
Dim Path As String
Dim TryAgain As Label 'label to loop back and try again
Dim ConnectionErr As Label 'Connection Error label
Dim Bypass As Label ' Jump to this to skip error block
ErrorCount = 0 ' Error counter for trying connection
Application.ScreenUpdating = False
ActiveWorkbook.Sheets("overall performers").Select
With Sheets("overall performers")
.Unprotect
.Range("L6").Value = CDate(.Range("L5"))
.Protect
End With
'------------------------------------------------------------
'Error module. Errors from -30 days from current date
'
'
' by C Mobberley 02/01/2010
'------------------------------------------------------------
'this module imports and produces the error list it follows on directly
'from the accuracyteamandstaffinfo module
Dim mydate As Date
Dim mydate2 As Date
mydate = Worksheets("overall performers").Range("L7")
mydate2 = Worksheets("overall performers").Range("M7")
Set WS = Sheets("Error")
Application.Calculation = xlCalculationManual
WS.Activate
WS.UsedRange.ClearContents
'What to do if there is a problem connecting to DB
TryAgain:
'Set the accuracymonitoring database path.
Path = "[URL="file://\\Dfz70588\106124001\workgroup\IPC"]\\Dfz70588\106124001\workgroup\IPC[/URL] CMT\AccuracyMonitoringApplication\AccuracyMonitoring.mdb"
On Error GoTo ConnectionErr
'Set the Database, and RecordSet along with the database password
Set Db = Workspaces(0).OpenDatabase(Path, _
True, True, "MS Access;PWD=bullseye")
' Select the distinct info of people with errrors on the error analysis page
'Set RS = Db.OpenRecordset("Select tblCheck.lTableID, tblCheck.sStaffNumber, tblError.sStaffNumber FROM tblCheck LEFT OUTER JOIN tblError ON tblCheck.lTableID = tblError.lCheckID WHERE dteCheckCompletedDate BETWEEN Date() AND Date() -30")
Set RS = Db.OpenRecordset("Select tblCheck.lTableID, tblCheck.sStaffNumber, tblError.sStaffNumber " & _
"FROM tblCheck LEFT OUTER JOIN tblError " & _
"ON tblCheck.lTableID = tblError.lCheckID " & _
"WHERE dteCheckCompletedDate BETWEEN " & _
"#" & mydate & "# AND #" & mydate2 & "#")
'This loop will collect the field names and place them in the first
'row starting at "A1"
For i = 0 To RS.Fields.Count - 1
WS.Cells(1, i + 1).Value = RS.Fields(i).Name
Next i
'copy from the record set and send it to the range below our headers
WS.Range("A2").CopyFromRecordset RS
'Close the connections
RS.Close
Db.Close
Set RS = Nothing
Set Db = Nothing
GoTo Bypass ' Jump over the error block if no errors found
'################################# Error Block ############################
ConnectionErr:
ErrorCount = ErrorCount + 1
Set RS = Nothing
Set Db = Nothing
' Set the number of times to retry the connection before bailing out
If ErrorCount > 5 Then
MsgBox "Error when trying to connect to the database, try again later. Accuracy information will not be Correct.", vbInformation, "UserMessage"
End
End If
GoTo TryAgain: 'Loop through if the errorcount is less than or equal to 5
'################################ End of the error block ###################
Bypass: ' Error Jump label
'Begin calculation loop to get unqiue check IDs
lastrowz = WS.Cells(Rows.Count, 1).End(xlUp).Row
WS.Range("D2").Select
Range("D2:D" & lastrowz).SpecialCells(xlCellTypeBlanks) = "=IF(RC[-3]<>R[-1]C[-3],RC[-3],"""")"
' 'Begin calculation loop to put staff number against the unique check
WS.Range("E2").Select
Range("E2:E" & lastrowz).SpecialCells(xlCellTypeBlanks) = "=IF(RC[-1]<>"""",RC[-3],"""")"
'Begin calculation loop to put staff number against the unique check
WS.Range("F2").Select
Range("F2:F" & lastrowz).SpecialCells(xlCellTypeBlanks) = "=IF(RC[-4]=RC[-3],RC[-3],"""")"
'Clear ws variable
Set WS = Nothing
'------------------------------------------------------------
'Staff module. for error calculations
'
'
' by C Mobberley 02/01/2010
'------------------------------------------------------------
Dim TryAgain2 As Label 'label to loop back and try again
Dim ConnectionErr2 As Label 'Connection Error label
Dim Bypass2 As Label ' Jump to this to skip error block
ErrorCount2 = 0 ' Error counter for trying connection
'Set where we want the data to be sent to
Set WS = Sheets("Staff")
TryAgain2:
'Set the accuracymonitoring database path.
Path = "[URL="file://\\Dfz70588\106124001\workgroup\IPC"]\\Dfz70588\106124001\workgroup\IPC[/URL] CMT\AccuracyMonitoringApplication\AccuracyMonitoring.mdb"
'lets clear out any old data on the sheet
WS.Activate
WS.UsedRange.ClearContents
'What to do if there is a problem connecting to DB
'Set the Database, and RecordSet along with the database password
Set Db = Workspaces(0).OpenDatabase(Path, _
True, True, "MS Access;PWD=bullseye")
On Error GoTo ConnectionErr2
'Select the distinct info of people with errrors on the error analysis page
Set RS = Db.OpenRecordset("SELECT DISTINCT tblImportStaff.sStaffNumber, tblImportStaff.sFirstName, tblImportStaff.sLastName, tlkpTeam.sTeam FROM tblImportStaff tblImportStaff, tlkpTeam tlkpTeam WHERE tblImportStaff.lTeamID = tlkpTeam.lID AND tblImportStaff.dteLeftIPC is null")
'This loop will collect the field names and place them in the first
'row starting at "A1"
For i = 0 To RS.Fields.Count - 1
WS.Cells(1, i + 1).Value = RS.Fields(i).Name
Next i
'copy from the record set and send it to the range below our headers
WS.Range("A2").CopyFromRecordset RS
'Close the connections
RS.Close
Db.Close
GoTo Bypass2 ' Jump over the error block if no errors found
'################################# Error Block ############################
ConnectionErr2:
ErrorCount2 = ErrorCount2 + 1
Set RS = Nothing
Set Db = Nothing
' Set the number of times to retry the connection before bailing out
If ErrorCount2 > 5 Then
MsgBox "Error when trying to connect to the database, try again later. Accuracy information will not be Correct.", vbInformation, "UserMessage"
End
End If
GoTo TryAgain2: 'Loop through if the errorcount is less than or equal to 5
'################################ End of the error block ###################
Bypass2: ' Error Jump label
'Now extract team name from the string
'Begin calculation loop to get team information for claims
WS.Activate
WS.Range("A1").Select
Dim lastone As Long
lastone = WS.Cells(Rows.Count, 1).End(xlUp).Row
WS.Range("E2").Select
Range("E2:E" & lastone).SpecialCells(xlCellTypeBlanks) = "=MID(SUBSTITUTE(RC[-1],LEFT(RC[-1],FIND("" "",RC[-1])),""""),1,4)"
'Begin calculation loop for number of unqiue checks
WS.Range("F2").Select
Range("F2:F" & lastone).SpecialCells(xlCellTypeBlanks) = "=COUNTIF(Error!C[-1],Staff!RC[-5])"
'Begin calculation loop for number of errors found in each check
WS.Range("G2").Select
Range("G2:G" & lastone).SpecialCells(xlCellTypeBlanks) = "=COUNTIF(Error!C[-1],Staff!RC[-6])"
'Begin calculation loop for number of errors per check
WS.Range("H2").Select
Range("H2:H" & lastone).SpecialCells(xlCellTypeBlanks) = "=IF(ISERROR(RC[-1]/RC[-2]),"""",RC[-1]/RC[-2])"
'Begin calculation loop for number of errors per check
WS.Range("I2").Select
Range("I2:I" & lastone).SpecialCells(xlCellTypeBlanks) = "=RC[-7] & "" "" & RC[-6]"
'Clear ws variable
Set WS = Nothing
Set RS = Nothing
Set Db = Nothing
' Call the addformulas macro
Call addaccuracyformulas
Application.Calculation = xlCalculationAutomatic
End Sub