software

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(quot;D:\Umer\10052006\Nur_IN_ISKV.mdbquot;)
Set rst = strDB.OpenRecordset(quot;Select distinct Dateiname From
ergebnis_brustkrebs_meco_mit_ISKV_MCquot;)

Set baseBook = ThisWorkbook

rst.MoveFirst
Debug.Print rst.RecordCount

baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;). Copy
Do Until rst.EOF
baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;). Copy
Dir = quot;D:\Umer\10052006\quot; amp; rst.Fields(0)
Debug.Print Dir
str = quot;Select * From
ergebnis_brustkrebs_meco_mit_ISKV_MC where Dateiname = 'quot; amp;
rst.Fields(0) amp; quot;'quot;

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(quot;Excel.Applicationquot;)
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 = quot;List1quot;
'Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;).Copy
Destination:=xlWs.Range(quot;A1quot;)
'baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;) .Copy
Destination:=xlWs.Range(quot;A1quot;)

xlWs.Range(quot;A1quot;).PasteSpecial Paste:=xlValues
xlWs.Name = quot;Liste_Dokuquot;

fldCount = rst2.Fields.Count

' Check version of Excel
If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version,
quot;.quot;) - 1)) gt; 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), quot;DD.MMM.YYYYquot;)

' Take care of OLE object fields or array
fields
ElseIf IsArray(recArray(iRow, iCol)) Then
recArray(iRow, iCol) = quot;Array Fieldquot;
End If
Next iRow 'next record
Next iCol 'next fieldxlWs.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(quot;Liste_Dokuquot;).Copy
after:=Worksheets(quot;Liste_Dokuquot;)baseBook.Worksheets(quot;Einführungquot;).Copy befo= _
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Copy befo= _
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Erläut_Liste_Dokuquot;).Copy befo=
_
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Erläut_Liste_Schul_abgel.quot;).C opy
after:= _
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Liste_Schul_abgelehntquot;).Copy
after:= _
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Erläut_Liste_Schul_nicht
wahrgquot;).Copy after:= _
xlWb.Sheets(quot;Liste_Dokuquot;)

baseBook.Worksheets(quot;Liste_Schul_nicht wahrgquot;).Copy
after:= _
xlWb.Sheets(quot;Liste_Dokuquot;)

'xlWs.Save

' A .. BY
Application.DisplayAlerts = False
xlWb.Worksheets(quot;Tabelle1quot;).Delete
xlWb.Worksheets(quot;Tabelle2quot;).Delete
xlWb.Worksheets(quot;Tabelle3quot;).Delete

Application.DisplayAlerts = True
'Debug.Print xlWb.Worksheets(quot;Liste_Dokuquot;).Rows.Count
colLength =
xlWb.Worksheets(quot;Liste_Dokuquot;).UsedRange.Rows.Count
'Worksheets(quot;Tabelle1quot;).Range(quot;A14quot;).Copy _

'destination:=Worksheets(quot;Tabelle2quot;).Range(quot;E5quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;A2:Aquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;A2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;B2:Bquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;B2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;C2:Cquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;C2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;G2:Gquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;D2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;H2:Hquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;E2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;BG2:BGquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;F2quot;)
xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;BS2:BSquot; amp;
colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
Ausschreib.quot;).Range(quot;G2quot;)

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 quot;Makro Completedquot;
Exit Sub
ErrorHandler:
MsgBox Err.Description
End Sub--
usiddiqi
------------------------------------------------------------------------
usiddiqi's Profile: www.excelforum.com/member.php...oamp;userid=34446
View this thread: www.excelforum.com/showthread...hreadid=542063Hi usiddiqi,

I don't think the problem is in the coding. It sounds like your CPU is just
hitting it's limit.

It's easy to check the code: close all your uneccessary programs so only
this is running.
Start your update : then : DO NOT TOUCH YOUR PC. if it runs OK when left on
it's own then the code is not the problem.

I have workbooks here that are very resource intensive and it will stop if
the user switches applications. Remember also that just because Task Manager
says 'not responding' doesn't always mean it's stopped. Sometimes it means
the program is just too busy to answer when the system queries it for a
status check but is actually still running.

HTH

Giz

quot;usiddiqiquot; wrote:

gt;
gt; Hi All,
gt;
gt; I have a mokro with the following code, to import data from a Access
gt; tabel and then create new excel sheets and update them and close
gt; them...normally the code runs fine, but when i switch task to some
gt; other programs already running, excel suddenly stops running, any idea
gt; ?
gt;
gt; CODE:
gt;
gt; Private Sub Command1_Click()
gt;
gt; On Error GoTo ErrorHandler
gt;
gt; Dim rst As Recordset
gt; Dim rst2 As Recordset
gt; Dim str As String
gt; Dim xlApp As Application
gt; Dim xlWb As Workbook
gt; Dim xlWs As Worksheet
gt;
gt; Dim Dir As String
gt;
gt; Dim baseBook As Workbook
gt;
gt; Dim recArray As Variant
gt;
gt; Dim i As Integer
gt; Dim j As Integer
gt; Dim strDB As Database
gt;
gt; Dim fldCount As Integer
gt; Dim recCount As Long
gt; Dim iCol As Integer
gt; Dim iRow As Integer
gt;
gt; Dim colLength As Integer
gt;
gt; Dim sheetCounter As Integer
gt; sheetCounter = 1
gt; ' Set the string to the path of your Northwind database
gt; Set strDB = OpenDatabase(quot;D:\Umer\10052006\Nur_IN_ISKV.mdbquot;)
gt; Set rst = strDB.OpenRecordset(quot;Select distinct Dateiname From
gt; ergebnis_brustkrebs_meco_mit_ISKV_MCquot;)
gt;
gt; Set baseBook = ThisWorkbook
gt;
gt; rst.MoveFirst
gt; Debug.Print rst.RecordCount
gt;
gt; baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;). Copy
gt; Do Until rst.EOF
gt; baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;). Copy
gt; Dir = quot;D:\Umer\10052006\quot; amp; rst.Fields(0)
gt; Debug.Print Dir
gt; str = quot;Select * From
gt; ergebnis_brustkrebs_meco_mit_ISKV_MC where Dateiname = 'quot; amp;
gt; rst.Fields(0) amp; quot;'quot;
gt;
gt; Set rst2 = strDB.OpenRecordset(str)
gt; If Not rst2.EOF Then
gt; rst2.MoveFirst
gt; rst2.MoveLast
gt; ' Create an instance of Excel and add a workbook
gt;
gt; Set xlApp = CreateObject(quot;Excel.Applicationquot;)
gt; Set xlWb = xlApp.Workbooks.Add
gt; Set xlWs = xlWb.Worksheets.Add
gt; 'xlApp.Visible = True
gt; 'xlApp.UserControl = True
gt;
gt; 'ActiveWorkbook.Names(1).Name = rst.Fields(0)
gt; 'ActiveWorkbook.Worksheets.Add
gt; 'ActiveSheet.Name = quot;List1quot;
gt; 'Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;).Copy
gt; Destination:=xlWs.Range(quot;A1quot;)
gt; 'baseBook.Worksheets(quot;Liste_Dokuquot;).Range(quot;A1:BY1quot;) .Copy
gt; Destination:=xlWs.Range(quot;A1quot;)
gt;
gt; xlWs.Range(quot;A1quot;).PasteSpecial Paste:=xlValues
gt; xlWs.Name = quot;Liste_Dokuquot;
gt;
gt; fldCount = rst2.Fields.Count
gt;
gt; ' Check version of Excel
gt; If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version,
gt; quot;.quot;) - 1)) gt; 8 Then
gt; 'EXCEL 2000 or 2002: Use CopyFromRecordset
gt;
gt; ' Copy the recordset to the worksheet, starting in
gt; cell A2
gt; xlWs.Cells(2, 1).CopyFromRecordset rst2
gt; 'Note: CopyFromRecordset will fail if the
gt; recordset
gt; 'contains an OLE object field or array data such
gt; 'as hierarchical recordsets
gt;
gt; Else
gt; 'EXCEL 97 or earlier: Use GetRows then copy array
gt; to Excel
gt;
gt; ' Copy recordset to an array
gt; rst2.MoveFirst
gt; ReDim recArray(rst2.RecordCount, fldCount)
gt; i = 0
gt; j = 0
gt; Do Until rst2.EOF
gt; For j = 0 To fldCount - 1
gt; recArray(i, j) = rst2.Fields(j)
gt; Next j
gt; i = i 1
gt; rst2.MoveNext
gt; Loop
gt;
gt; recCount = rst2.RecordCount
gt;
gt; For iCol = 0 To fldCount - 1
gt; For iRow = 0 To recCount - 1
gt; ' Take care of Date fields
gt; If IsDate(recArray(iRow, iCol)) Then
gt;
gt; recArray(iRow, iCol) =
gt; Format(recArray(iRow, iCol), quot;DD.MMM.YYYYquot;)
gt;
gt; ' Take care of OLE object fields or array
gt; fields
gt; ElseIf IsArray(recArray(iRow, iCol)) Then
gt; recArray(iRow, iCol) = quot;Array Fieldquot;
gt; End If
gt; Next iRow 'next record
gt; Next iCol 'next field
gt;
gt;
gt; xlWs.Cells(2, 1).Resize(recCount, fldCount).Value =
gt; recArray
gt; End If
gt;
gt; ' Auto-fit the column widths and row heights
gt; xlWs.Columns.AutoFit
gt; xlWs.Rows.AutoFit
gt;
gt; xlWb.Activate
gt; xlWb.SaveAs FileName:=Dir
gt;
gt; xlWb.Close
gt; xlApp.Quit
gt; Set xlWb = Workbooks.Open(Dir)
gt;
gt;
gt; 'xlWb.Worksheets(quot;Liste_Dokuquot;).Copy
gt; after:=Worksheets(quot;Liste_Dokuquot;)
gt;
gt;
gt; baseBook.Worksheets(quot;Einführungquot;).Copy befo= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Copy befo= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Erläut_Liste_Dokuquot;).Copy befo=
gt; _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Erläut_Liste_Schul_abgel.quot;). Copy
gt; after:= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Liste_Schul_abgelehntquot;).Copy
gt; after:= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Erläut_Liste_Schul_nicht
gt; wahrgquot;).Copy after:= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; baseBook.Worksheets(quot;Liste_Schul_nicht wahrgquot;).Copy
gt; after:= _
gt; xlWb.Sheets(quot;Liste_Dokuquot;)
gt;
gt; 'xlWs.Save
gt;
gt; ' A .. BY
gt; Application.DisplayAlerts = False
gt; xlWb.Worksheets(quot;Tabelle1quot;).Delete
gt; xlWb.Worksheets(quot;Tabelle2quot;).Delete
gt; xlWb.Worksheets(quot;Tabelle3quot;).Delete
gt;
gt; Application.DisplayAlerts = True
gt;
gt;
gt;
gt; 'Debug.Print xlWb.Worksheets(quot;Liste_Dokuquot;).Rows.Count
gt; colLength =
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).UsedRange.Rows.Count
gt; 'Worksheets(quot;Tabelle1quot;).Range(quot;A14quot;).Copy _
gt;
gt; 'destination:=Worksheets(quot;Tabelle2quot;).Range(quot;E5quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;A2:Aquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;A2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;B2:Bquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;B2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;C2:Cquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;C2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;G2:Gquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;D2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;H2:Hquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;E2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;BG2:BGquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;F2quot;)
gt; xlWb.Worksheets(quot;Liste_Dokuquot;).Range(quot;BS2:BSquot; amp;
gt; colLength).Copy Destination:=xlWb.Worksheets(quot;Kurzübersicht_alle
gt; Ausschreib.quot;).Range(quot;G2quot;)
gt;
gt; xlWb.Save
gt; xlWb.Close
gt;
gt; End If
gt;
gt; rst.MoveNext
gt;
gt; Loop
gt;
gt; ' Close ADO objects
gt; rst.Close
gt; Set rst = Nothing
gt; Set cnt = Nothing
gt;
gt; ' Release Excel references
gt; Set xlWs = Nothing
gt; Set xlWb = Nothing
gt;
gt; Set xlApp = Nothing
gt; MsgBox quot;Makro Completedquot;
gt; Exit Sub
gt; ErrorHandler:
gt; MsgBox Err.Description
gt; End Sub
gt;
gt;
gt; --
gt; usiddiqi
gt; ------------------------------------------------------------------------
gt; usiddiqi's Profile: www.excelforum.com/member.php...oamp;userid=34446
gt; View this thread: www.excelforum.com/showthread...hreadid=542063
gt;
gt;


Hi..
first thanks for ur reply...
yeah i think too. coz when i left it untouched, the prog. did run fine,
but whenever i switch task, the excel just dissappear from the taskbar,
and also its entry dissapear from the task manager, its not like
something very common quot;not respondingquot; thing.

anyway i have no idea about this thing...ok lets suppose its due to
machine limitation, any idea of changing my code machine/memory
efficient.

Regards,
Umer--
usiddiqi
------------------------------------------------------------------------
usiddiqi's Profile: www.excelforum.com/member.php...oamp;userid=34446
View this thread: www.excelforum.com/showthread...hreadid=542063