VBA error handling issue

[munkee]

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.

1. The basic setup of the whole code is as follows:
2. Calculate a date to be input in to a sql string.
3. Connect to the database
4. Select the records
5. Import them in to excel
6. Carry out some calculations

The basic setup of the error handling is as follows:

1. The basic setup of the whole code is as follows:
2. Calculate a date to be input in to a sql string.
3. Connect to the database
4. If error produced when trying to connect loop through the connection 5 times.
5. If still unable to connect succesfully display an alert and continue with the rest of the procedures in the sheet.
6. If the code connects fine, then skip the error handling and continue with calculations.

The code is as follows:

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

 

[Andrew Poulsom]

I think:

GoTo TryAgain:

should be:

Resume TryAgain

For more information look here:

http://www.cpearson.com/Excel/ErrorHandling.htm

 

[munkee]

Thanks for the quick reply Andrew, I've amended where you showed after reading up on the link. It seems to make sense. Also noticed I had

On Error GoTo ConnectionErr

Instead of

On Error GoTo ConnectionErr:

Do you know if there is a method of replicating errors? So that I can test if this now works? I can't afford to replicate the error myself by opening the database as it will be having data input into it by a few teams at the moment and I dont want to lock it up.

 

[Andrew Poulsom]

You don't need the colon except in the label itself.

Why don't you write a bit of code that raises an error (eg by dividing by zero) to test your construction.