Hi All,

I have a mokro with the following code, to import data from a Access tabel and then create new excel sheets and update them and close them...normally the code runs fine, but when i switch task to some other programs already running, excel suddenly stops running, any idea ?

CODE:

Private Sub Command1_Click()

On Error GoTo ErrorHandler

Dim rst As Recordset
Dim rst2 As Recordset
Dim str As String
Dim xlApp As Application
Dim xlWb As Workbook
Dim xlWs As Worksheet

Dim Dir As String

Dim baseBook As Workbook

Dim recArray As Variant

Dim i As Integer
Dim j As Integer
Dim strDB As Database

Dim fldCount As Integer
Dim recCount As Long
Dim iCol As Integer
Dim iRow As Integer

Dim colLength As Integer

Dim sheetCounter As Integer
sheetCounter = 1
' Set the string to the path of your Northwind database
Set strDB = OpenDatabase("D:\Umer\10052006\Nur_IN_ISKV.mdb")
Set rst = strDB.OpenRecordset("Select distinct Dateiname From ergebnis_brustkrebs_meco_mit_ISKV_MC")

Set baseBook = ThisWorkbook

rst.MoveFirst
Debug.Print rst.RecordCount

baseBook.Worksheets("Liste_Doku").Range("A1:BY1").Copy
Do Until rst.EOF
baseBook.Worksheets("Liste_Doku").Range("A1:BY1").Copy
Dir = "D:\Umer\10052006\" & rst.Fields(0)
Debug.Print Dir
str = "Select * From ergebnis_brustkrebs_meco_mit_ISKV_MC where Dateiname = '" & rst.Fields(0) & "'"

Set rst2 = strDB.OpenRecordset(str)
If Not rst2.EOF Then
rst2.MoveFirst
rst2.MoveLast
' Create an instance of Excel and add a workbook

Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets.Add
'xlApp.Visible = True
'xlApp.UserControl = True

'ActiveWorkbook.Names(1).Name = rst.Fields(0)
'ActiveWorkbook.Worksheets.Add
'ActiveSheet.Name = "List1"
'Worksheets("Liste_Doku").Range("A1:BY1").Copy Destination:=xlWs.Range("A1")
'baseBook.Worksheets("Liste_Doku").Range("A1:BY1").Copy Destination:=xlWs.Range("A1")

xlWs.Range("A1").PasteSpecial Paste:=xlValues
xlWs.Name = "Liste_Doku"

fldCount = rst2.Fields.Count

' Check version of Excel
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
'EXCEL 2000 or 2002: Use CopyFromRecordset

' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 1).CopyFromRecordset rst2
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets

Else
'EXCEL 97 or earlier: Use GetRows then copy array to Excel

' Copy recordset to an array
rst2.MoveFirst
ReDim recArray(rst2.RecordCount, fldCount)
i = 0
j = 0
Do Until rst2.EOF
For j = 0 To fldCount - 1
recArray(i, j) = rst2.Fields(j)
Next j
i = i + 1
rst2.MoveNext
Loop

recCount = rst2.RecordCount

For iCol = 0 To fldCount - 1
For iRow = 0 To recCount - 1
' Take care of Date fields
If IsDate(recArray(iRow, iCol)) Then

recArray(iRow, iCol) = Format(recArray(iRow, iCol), "DD.MMM.YYYY")

' Take care of OLE object fields or array fields
ElseIf IsArray(recArray(iRow, iCol)) Then
recArray(iRow, iCol) = "Array Field"
End If
Next iRow 'next record
Next iCol 'next field


xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = recArray
End If

' Auto-fit the column widths and row heights
xlWs.Columns.AutoFit
xlWs.Rows.AutoFit

xlWb.Activate
xlWb.SaveAs FileName:=Dir

xlWb.Close
xlApp.Quit
Set xlWb = Workbooks.Open(Dir)


'xlWb.Worksheets("Liste_Doku").Copy after:=Worksheets("Liste_Doku")


baseBook.Worksheets("Einführung").Copy before:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Kurzübersicht_alle Ausschreib.").Copy before:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Erläut_Liste_Doku").Copy before:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Erläut_Liste_Schul_abgel.").Copy after:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Liste_Schul_abgelehnt").Copy after:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Erläut_Liste_Schul_nicht wahrg").Copy after:= _
xlWb.Sheets("Liste_Doku")

baseBook.Worksheets("Liste_Schul_nicht wahrg").Copy after:= _
xlWb.Sheets("Liste_Doku")

'xlWs.Save

' A .. BY
Application.DisplayAlerts = False
xlWb.Worksheets("Tabelle1").Delete
xlWb.Worksheets("Tabelle2").Delete
xlWb.Worksheets("Tabelle3").Delete

Application.DisplayAlerts = True



'Debug.Print xlWb.Worksheets("Liste_Doku").Rows.Count
colLength = xlWb.Worksheets("Liste_Doku").UsedRange.Rows.Count
'Worksheets("Tabelle1").Range("A1:D4").Copy _
'destination:=Worksheets("Tabelle2").Range("E5")
xlWb.Worksheets("Liste_Doku").Range("A2:A" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("A2")
xlWb.Worksheets("Liste_Doku").Range("B2:B" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("B2")
xlWb.Worksheets("Liste_Doku").Range("C2:C" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("C2")
xlWb.Worksheets("Liste_Doku").Range("G2:G" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("D2")
xlWb.Worksheets("Liste_Doku").Range("H2:H" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("E2")
xlWb.Worksheets("Liste_Doku").Range("BG2:BG" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("F2")
xlWb.Worksheets("Liste_Doku").Range("BS2:BS" & colLength).Copy Destination:=xlWb.Worksheets("Kurzübersicht_alle Ausschreib.").Range("G2")

xlWb.Save
xlWb.Close

End If

rst.MoveNext

Loop

' Close ADO objects
rst.Close
Set rst = Nothing
Set cnt = Nothing

' Release Excel references
Set xlWs = Nothing
Set xlWb = Nothing

Set xlApp = Nothing
MsgBox "Makro Completed"
Exit Sub
ErrorHandler:
MsgBox Err.Description
End Sub