I am trying to read and then update an Access Database using Excel VBA
code. When I run the code below on a PC that has XP/Excel & Access
2003 - it works fine. When I run the same code on my home computer -
which has VISTA/Excel & Access 2007 - it fails with a "Microsoft
Database Engine Stopped because you and another user are attempting to
change the same data at the same time" error.

BUT - when I step through the code - it works fine, so the problem has
something to do with the Code executing too fast for the ODBC
connection??? Not sure if it is VISTA, or if it has something to do
with the 2007 version of EXCEL or ACCESS.

Has anyone else run into this?? And/or does anyone have a solution as
to how I could slow it all down, so it works.

HELP.......


Dim rs As Recordset
Set rs = CreateObject("ADODB.Recordset")
Dim rs2 As Recordset
Set rs2 = CreateObject("ADODB.Recordset")
Dim rsTeam As Recordset
Set rsTeam = CreateObject("ADODB.Recordset")
Dim rsIce As Recordset
Set rsIce = CreateObject("ADODB.Recordset")
Dim sLevel As String
Dim sSql As String
Dim sSql2 As String
Dim sSqlUpdt1 As String
Dim sSqlUpdt2 As String
Dim sNov As Integer
Dim sDec As Integer
Dim sJan As Integer
Dim sFeb As Integer
Dim sMar As Integer
Dim sIceMax As Integer
Dim sMoAvg As Integer
Dim sLastDt As Date
Dim sLvlCnt As Integer
Dim sAlldone As Boolean
Dim sTeam As String
Dim sIceCnt As Integer
Dim sEventStart As Date
Dim sHrsDone As Boolean
Dim sOrder As Integer


sAlldone = False
sTime = "#12/30/1899 8:0:0#"
sHrsDone = False


Do Until sAlldone
sSql2 = "SELECT SchedDate, EventStart, Home, home_level,
Event_Type " & _
"FROM Initiation_ice " & _
"WHERE home = '' " & _
"AND EventStart < " & sTime & _
" order by schedDate" & ";"
With rsIce
.Source = sSql2
.ActiveConnection = "ice_scheduling"
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open
If rsIce.RecordCount = 0 Then
sAlldone = True
rsIce.Close
Else
res = rsIce.GetRows
lrows = UBound(res, 2)

r = 0
sIceDate = res(0, r)
sMonth = Month(sIceDate)
sMonthName = MonthName(sMonth)

sSql = "SELECT Team, Hours_rcvd, max_hrs, hours_complete,
assign_order, team_information.level, " & _
"nov_hrs, dec_hrs, jan_hrs, feb_hrs, mar_hrs " & _
"FROM team_information " & _
"WHERE hours_complete = " & sHrsDone & _
" order by hours_rcvd, assign_order" & ";"
With rsTeam
.Source = sSql
.ActiveConnection = "ice_scheduling"
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open
If rsTeam.RecordCount = 0 Then
sAlldone = True
rsTeam.Close
Else
res = rsTeam.GetRows
lrows = UBound(res, 2)

r = 0
sTeam = res(0, r)
sIceCnt = res(1, r)
sIceMax = res(2, r)
sOrder = res(4, r)
sLevel = res(5, r)
sIceCnt = sIceCnt + 1
sNov = res(6, r)
sDec = res(7, r)
sJan = res(8, r)
sFeb = res(9, r)
sMar = res(10, r)
If sMonthName = "November" Then
sNov = sNov + 1
Else
If sMonthName = "December" Then
sDec = sDec + 1
Else
If sMonthName = "January" Then
sJan = sJan + 1
Else
If sMonthName = "February" Then
sFeb = sFeb + 1
Else
sMar = sMar + 1
End If
End If
End If
End If

With rsTeam
If .EOF Then
.MoveFirst

If sIceCnt = sIceMax Then
.Fields(3).Value = True
.Fields(1).Value = sIceCnt
.Fields(6).Value = sNov
.Fields(7).Value = sDec
.Fields(8).Value = sJan
.Fields(9).Value = sFeb
.Fields(10).Value = sMar
.Update
Else
.Fields(1).Value = sIceCnt
.Fields(6).Value = sNov
.Fields(7).Value = sDec
.Fields(8).Value = sJan
.Fields(9).Value = sFeb
.Fields(10).Value = sMar
.Update
End If
End If

End With

rsTeam.Close

End If
End With
If sAlldone = False Then
With rsIce
If .EOF Then
.MoveFirst
.Fields(2).Value = sTeam
.Fields(3).Value = sLevel
.Fields(4).Value = "Practice"
.Update
End If
End With
End If

rsIce.Close

End If
End With
Loop

End Sub