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 befo= _
xlWb.Sheets("Liste_Doku")

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

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

baseBook.Worksheets("Erläut_Liste_Schul_abgel.").C opy
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


--
usiddiqi
------------------------------------------------------------------------
usiddiqi's Profile: http://www.excelforum.com/member.php...o&userid=34446
View this thread: http://www.excelforum.com/showthread...hreadid=542063