LinkBack URL
About LinkBacks
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
Register To Reply
Bookmarks