Error 1004

I know this code is pretty ugly but I've been trying different things to try to get past the problem and haven't had a chance to clean things up yet.  My problem is that the code will import the first two records from a spreadsheet and then it fails on the third pass.  The error is:  Run-time error '1004':  Method 'Range' of object '_Application' failed.  I have included the code and marked before and after the line marked by the debugger with a comment line of *******.

Thanks in advance for any help.

Jim

Public Sub ImportSheet()

Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim x
Dim strQuery As String
Dim strEmpNum As String
Dim strProjCode As String
Dim strRegHrs As String
Dim strOTHrs As String
Dim strDate As String
Dim strSQL As String
Dim strTS As String
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim rsRecMap As ADODB.Recordset
Dim strSQLChange As String
Dim intRecCount As Integer
Dim Qy As New ADODB.Command
Dim nOldRegHrs As Long
Dim nOldOTHrs As Long
Dim strRecNum As String
Dim strComments
Dim i As Integer
 
Dim strTSRecNum As String
Dim strTSEmpNum As String
Dim strTSProjCode As String
Dim strTSRegHrs As String
Dim strTSOTHrs As String
Dim strTSDate As String
Dim strTSComments
Dim txtSQL As String
 
Dim txtEmpNum As String
Dim txtProjCode As String
Dim txtRegHrs As String
Dim txtOTHrs As String
Dim txtDate As String
Dim txtRecNum As String
Dim txtComments As String
   
strQuery = ""
strEmpNum = ""
strProjCode = ""
strRegHrs = 0
strOTHrs = 0
strDate = ""
strRecNum = ""
strComments = ""
 
Set xlApp = New Excel.Application
 
For x = 0 To Me.lst_target.ListCount - 1
  If Me.lst_target.Selected(x) Then
      strQuery = lst_target.ItemData(x)
  End If
 
  Set xlBook = xlApp.Workbooks.Open(FileName:=Trim(strQuery))
  Set xlSheet = xlApp.Sheets("Castle Timesheet")
       
  txt_nowImporting.SetFocus
  txt_nowImporting.Text = "Now Importing " & " " & strQuery
       
  Set conn = CurrentProject.AccessConnection

  ' Create 2 instances of the ADO record class, and
  ' set its properties
       
  Set rsRecMap = New ADODB.Recordset
  rsRecMap.Open "select * from Record_Map", conn, _
     adOpenKeyset, adLockOptimistic
  rsRecMap.MoveFirst
  For i = 1 To 96
  ' these variables are now referencing worksheet  
  ' locations on the Excel spreadsheet

   strEmpNum = rsRecMap.Fields(1).Value
   strDate = rsRecMap.Fields(2).Value
   strProjCode = rsRecMap.Fields(3).Value
   strRegHrs = rsRecMap.Fields(4).Value
   strOTHrs = rsRecMap.Fields(5).Value
   strComments = rsRecMap.Fields(6).Value
           
   ' these are the actual cell values
           
   strTSEmpNum = xlApp.Range(strEmpNum).Value
   strTSProjCode = xlApp.Range(strProjCode).Value
   strTSDate = xlApp.Range(strDate).Value
   trTSRegHrs = xlApp.Range(strRegHrs).Value
' *************** debugger stops on this next line
   strTSOTHrs = xlApp.Range(strOTHrs).Value
' ************************************************
   strTSComments = xlApp.Range(strComments).Value
                       
     Set rs = New ADODB.Recordset
     rs.Open "Select * from timesheet", _
        CurrentProject.Connection, _
        adOpenKeyset, adLockOptimistic

     If rs.AbsolutePosition = adPosUnknown Then
       rs.AddNew
       rs!Emp_Number = strTSEmpNum
       rs![Date Worked] = strTSDate
       rs!Project_Code = strTSProjCode
       rs![Regular Hours] = strTSRegHrs
       rs![Overtime Hours] = strTSOTHrs
       rs![Worksheet Comments] = IIf(IsNull(rs![Worksheet Comments]), "", rs![Worksheet Comments] = strTSComments)
       rs.Update
     Else
       rs.MoveFirst
       rs.MoveLast

       intRecCount = rs.RecordCount
       rs.MoveFirst
       If rs.RecordCount > 0 Then
         Dim icount
         For icount = 0 To rs.RecordCount - 1
           ' if there is a matching record then update it
           If rs![Emp_Number] = strTSEmpNum And rs![Date Worked] = strTSDate And rs![Project_Code] = strTSProjCode Then
            strSQLChange = "update timesheet
            SET [Regular Hours] = '" & strTSRegHrs & "', " & _
            "[Overtime Hours] ='" & strTSOTHrs & "'" & _
            "where Emp_Number = '" & strTSEmpNum & "'" & _
            " and [Date Worked] = #" & strTSDate & "#" & _
            " and Project_Code = '" & strTSProjCode & "'"
            Qy.ActiveConnection = conn
            Qy.CommandText = strSQLChange
            Qy.CommandType = adCmdText
            Qy.Execute
         Exit For
         rs.MoveNext
       Else
         ' if there is no record that matches then you
         '  have to insert one
         rs.AddNew
         rs!Emp_Number = strTSEmpNum
         rs![Date Worked] = strTSDate
         rs!Project_Code = strTSProjCode
         rs![Regular Hours] = strTSRegHrs
         rs![Overtime Hours] = strTSOTHrs
         rs![Worksheet Comments] = strTSComments
         rs.Update
       End If
       DoEvents
       Next icount
     Else
' if there is no records in the table then you have to  
' insert one
       rs.AddNew
       rs!Emp_Number = strTSEmpNum
       rs![Date Worked] = strTSDate
       rs!Project_Code = strTSProjCode
       rs![Regular Hours] = strTSRegHrs
       rs![Overtime Hours] = strTSOTHrs
       rs![Worksheet Comments] = strTSComments
       rs.Update
     End If
   End If
   strEmpNum = rsRecMap.Fields(1).Value
   strDate = rsRecMap.Fields(2).Value
   strProjCode = rsRecMap.Fields(3).Value
   strRegHrs = rsRecMap.Fields(4).Value
   strOTHrs = rsRecMap.Fields(5).Value
   strComments = rsRecMap.Fields(6).Value
               
   ' these are the actual cell values
           
   strTSEmpNum = xlApp.Range(strEmpNum).Value
   strTSProjCode = xlApp.Range(strProjCode).Value
   strTSRegHrs = xlApp.Range(strRegHrs).Value
   strTSOTHrs = xlApp.Range(strOTHrs).Value
   strTSDate = xlApp.Range(strDate).Value
   strTSComments = xlApp.Range(strComments).Value
           
   rsRecMap.MoveNext
   Next i
               
   MsgBox "The Import cycle is completed."

    'xlApp.Workbooks(trim(strQuery)).Close savechanges:=False
        DoEvents
    Next x

    If x = Me.lst_target.ListCount Then
      txt_nowImporting.SetFocus
      txt_nowImporting.Text = "Import Done" & " " & x & " " & "Total Files Imported"
    End If
   
    DoEvents
   
    'Close Microsoft Excel and destroy object variables
    xlApp.Quit
    Set xlApp = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set rs = Nothing
    Set rsRecMap = Nothing
    Set conn = Nothing
    DoEvents
End Sub