Component Request Pending

[RGregoire]

I have a program that transfers data from an Excel file to an Access database using DAO.

The problem I am having is when I'm transferring a large amount of data the program locks up. When I click anywhere I get a message box as follows:

Component Request Pending
This action cannot be completed because the other
application is busy. Choose 'Switch To' to activate
the busy application and correct the problem.

When I select the 'Switch To' I get a list of applications currently running. But, everything locks up and I am unable to select any of the applications. I end up having to re-boot the computer.

Following is the code -

'Form wide variables
Option Explicit
Private RecordCount As Long
Private XL As Excel.Application
Private WB As Excel.Workbook
Private WS As Excel.Worksheet

Private Sub cmdTransferData_Click()

Screen.MousePointer = vbHourglass

Set XL = New Excel.Application
Set WB = XL.Workbooks.Open(App.Path & "\Warranty.xls")
Set WS = WB.Worksheets(1)

XL.DisplayAlerts = False


(Other actions)

AddPartNumberInformation

WB.Close
XL.Quit

Set WS = Nothing
Set WB = Nothing
Set XL = Nothing


End Sub



Private Sub AddPartNumberInformation()

Dim DB As DAO.Database
Dim RS As DAO.Recordset

Dim N As Integer, A As Integer
Dim CurClaimNum As String

On Error GoTo ErrorHandler

'Add Claim Parts Information to Database
Set DB = OpenDatabase(App.Path & "\Warranty.mdb")
Set RS = DB.OpenRecordset("PartsInformation", dbOpenTable)

For N = 1 To RecordCount
If Trim(WS.Cells(N, 4)) <> "" Then
CurClaimNum = Trim(WS.Cells(N, 4))
RS.AddNew
RS!ClaimNumber = CurClaimNum
If Trim(WS.Cells(N, 5)) <> "" Then
If Left(WS.Cells(N, 5), 2) = "TO" Then
RS!PartNumber = Right(WS.Cells(N, 5), Len(WS.Cells(N, 5)) - 2)
Else
RS!PartNumber = WS.Cells(N, 5)
End If
Else
RS!PartNumber = "(no parts)"
End If
RS!PartQty = WS.Cells(N, 6)
RS!PartDescription = WS.Cells(N, 7)
RS.Update
'Find Other parts associated with claim
Do Until Trim(WS.Cells(N + 1, 3)) <> ""
RS.AddNew
RS!ClaimNumber = CurClaimNum
If Trim(WS.Cells(N + 1, 5)) <> "" Then
If Left(WS.Cells(N + 1, 5), 2) = "TO" Then
RS!PartNumber = Right(WS.Cells(N + 1, 5), Len(WS.Cells(N + 1, 5)) - 2)
Else
RS!PartNumber = WS.Cells(N + 1, 5)
End If
Else
RS!PartNumber = "(no parts)"
End If
RS!PartQty = WS.Cells(N + 1, 6)
RS!PartDescription = WS.Cells(N + 1, 7)
RS.Update
If N >= RecordCount Then
Exit Do
Else
N = N + 1
End If
Loop
End If
Me.pgbDataTransfer.Value = Me.pgbDataTransfer.Value + 1
'DoEvents
Next N

Me.pgbDataTransfer.Value = Me.pgbDataTransfer.Max
'DoEvents



RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing

Exit Sub

ErrorHandler:
If Err.Number = 3022 Then
Debug.Print "Error on N = " & N & " A = " & A
Resume Next
Else
RS.Close
DB.Close
Set RS = Nothing
Set DB = Nothing
WB.Close
XL.Quit
Set WS = Nothing
Set WB = Nothing
Set XL = Nothing

MsgBox "Module AddPartNumberInformation" & vbCrLf & vbCrLf & Err.Number & vbCrLf & Err.Description, 16, "Error Message"
End If

End Sub


Any and all help appreciated

Thanks - Ron Gregoire

[M Owen]

Ron,

Did you try uncommenting the DoEvents within your loop? You might need to put in a few more of them also ...

[RGregoire]

Originally I had the DoEvents uncommented. I thought that using the DoEvents was causing the problem.