Help tidying up some current code that causes errors

[rrenis]

Hi all :hi:

I have the following code that has been adapted from some code that was kindly posted by KeithRoberts. It runs from MS Project but I've posted here as I'm sure the problems lie with what is occuring with Excel.

1) Ideally I'd like to be able to change the way the task dates are added to the row within excel but I'm not sure how to do it :(. The reason for this is that I think the global Excel.Range is causing a problem with the code. This is because an instance of Excel is left running in my process list after the code is run (sometimes, but not always) which seems to effect how reliable the export is. ometimes for instance no data is written to the excel file.

2) Also, I've noticed that on some PC's I get an ActiveX error when the code trys to determine if an instance of Excel is running - this part of the code was added to try and counter to the problems of Excel not shutting down properly from previous attempts of running the code.

3) Finally, I also sometimes receive a server response error when trying to open the data.xls file but I have no idea why? :dunno

If anyone has any ideas on how to improve the way the data is added to excel I'd be very grateful, especially if there is a way to remove the global Excel.Range : pray2: (as I'm sure this would solve point 2 as I could remove the check to see if Excel is running).

' References - Microsoft Scripting Runtime AND Microsoft Excel 11.0 Object Library
Option Explicit
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Sub ExportTasks()

ResumeExportTasks:

Dim RemoteServerError As Integer

Application.ScreenUpdating = False

Dim fso As New FileSystemObject
Dim xlApp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim xlWorkSheet As Object
Dim tsk As Task
Dim Tsks As Tasks
Dim TaskNumber As Integer
Dim sRef As String
Dim NewApp As String
Dim myHeader As String

Dim MYTerminate As String
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim intError As Integer

On Error Resume Next

' the following checks to see whether excel is running, and if not creates an excel application
Set xlApp = GetObject(, "Excel.Application") ' THIS SOMETIMES CREATES AN ACTIVEX ERROR
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
NewApp = True
Else
NewApp = False
End If

On Error GoTo 0

xlApp.Visible = False
xlApp.ScreenUpdating = False
Set xlbook = xlApp.Workbooks.Add
Set xlsheet = xlbook.Worksheets.Add
xlApp.Calculation = xlManual
xlApp.CalculateBeforeSave = False
xlApp.DisplayAlerts = False

On Error GoTo ErrorMessage

Dim Rng As Range
Dim SheetName As String
Dim toDel As Range

MY_Progress.Show ' USERFORM - this just loads up to show that the code is running - not essential if anyone thinks this could cause a problem
DoEvents

sRef = Left(ActiveProject.Name, 5) ' get the project reference from the Project filename
SheetName = "MY_Data"
Workbooks.Open FileName:="C:\Data.xls", UpdateLinks:=3 ' THIS SOMETIMES CAUSES A SERVER RESPONSE ERROR

Dim sht As Object
Sheets(SheetName).Select
Set Rng = ActiveWorkbook.Worksheets(SheetName).Range("A:A")

' the following find the existing reference in the excel spreadsheet and if found deletes it so that the new dates can be written
FindRef:
Set toDel = Rng.Find(sRef)
If toDel Is Nothing Then GoTo PasteData Else
Rng.Parent.Rows(toDel.Row).Delete
GoTo FindRef

PasteData:
Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
Set xlRow = xlApp.ActiveCell

' the following is specific to exporting the MS Project task dates to excel
TaskNumber = 0

Set Tsks = ActiveProject.Tasks
For Each tsk In Tsks
If Not tsk Is Nothing Then
NextTaskStart:
Set xlCol = xlRow.Offset(0, TaskNumber)
If TaskNumber = 0 Then xlCol = sRef
rgt 1
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1 ' used to move the excel offset value to the next column to correspond with the tasknumber
myHeader = Range("A1").Offset(0, TaskNumber).Value

If myHeader <> tsk.Name & " Start" Then GoTo NextTaskStart ' compare task name with column header so that correct dates are added against corresponding task names in the columns (this is here as some of the headers may not be present as task names in MS Project
xlCol = tsk.Start
rgt 1
NextTaskFinish:
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1
myHeader = Range("A1").Offset(0, TaskNumber).Value
If myHeader <> tsk.Name & " Finish" Then GoTo NextTaskFinish ' as above but for task finish, not task start
Set xlCol = xlRow.Offset(0, TaskNumber)
xlCol = tsk.Finish
End If
Next tsk

ActiveWorkbook.Close savechanges:=True

If NewApp = True Then

MYTerminate = "Excel.exe" ' the following code attempts to close any instances of excel left running is a new object has been created

Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")

Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")

If objList.Count = 0 Then GoTo MYExit Else

For Each objProcess In objList
intError = objProcess.Terminate
Next

MYExit:
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing

Else
xlApp.Quit

End If

Set xlApp = Nothing
Set fso = Nothing

Unload MY_Progress

Application.ScreenUpdating = True

MsgBox "Data for project " & sRef & " has been successfully exported. ", , "Data Export"

GoTo MacroExit

Exit Sub

TaskError:

MsgBox "The following Task name cannot be found in the Database: " & vbNewLine & _
" " & vbNewLine & _
tsk.Name & vbNewLine & _
" ", 0, "Faliure"

MacroExit:

If NewApp = True Then

MYTerminate = "Excel.exe"

Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")

Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")

If objList.Count = 0 Then GoTo MYExit Else

For Each objProcess In objList
intError = objProcess.Terminate
Next

MYExit:

Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing

Else
xlApp.Quit

End If

Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Set fso = Nothing
Application.ScreenUpdating = True

If RemoteServerError = 1 Then GoTo ResumeExportTasks

Exit Sub

ErrorMessage:
RemoteServerError = RemoteServerError + 1
If RemoteServerError = 1 Then GoTo MacroExit

MsgBox "An unexpected error has occurred." _
& vbCrLf & "Macro Name: ExportTasks" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MacroExit

End Sub
Sub dwn(i As Integer)
Set xlRow = xlRow.Offset(i, 0)
End Sub
Sub rgt(i As Integer)
Set xlCol = xlCol.Offset(0, i)
End Sub
Thanks for looking :thumb

Cheers,
rrenis

[rinser]

Wow, there is quite some code there... :)
A few more comments probably wouldn't hurt... :)

[rrenis]

Hi rinser, I've added a few comments which I hope will make more sense of it. Sorry. :o:

Really all I'm after is some help at re-working the way of moving the active column in excel to the right so I can perform a compare in the title row (1) against the task name in MS Project and if successful paste in the corresponding date from the task start or finish. At the moment it uses Excel.Range but I think this is the cause of some of the problems in terms of leaving an instance of excel running in my process list.

I don't have to use the code to find the last row, I could instead insert a new row 2 and paste the data into there so that hopefully the rows will always be the same in which the compare (row 1) and paste (row 2) is performed so maybe excel.range could be omitted?

Hope this helps make more sense of what I posted above.

Cheers,
rrenis

[Kenneth Hobs]

Maybe this will help. I do this in MSWord. I like to use both late and early binding to take advantage of both worlds.
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range

'http://www.vbaexpress.com/forum/showthread.php?p=171977
Sub CreateTestXLS()
Dim xlApp As Excel.Application 'Early Binding
'Dim xlApp As Object 'Late Binding
Dim xlsheet As Excel.Worksheet
Dim xlbook As Excel.Workbook
Dim r As Excel.Range

On Error GoTo theEnd

Set xlApp = CreateObject("excel.application") 'Better method
'Set xlApp = New Excel.Application
xlApp.Visible = False
xlApp.ScreenUpdating = False
Set xlbook = xlApp.Workbooks.Add
Set xlsheet = xlbook.Worksheets.Add
xlsheet.Name = "Greetings"
Set r = xlsheet.Range("A1")
r.Value = "Hello World!"

On Error Resume Next
Kill "c:\temp\test.xls"
On Error GoTo theEnd
xlbook.SaveAs "c:\temp\test.xls"
xlbook.Close False

theEnd:
On Error Resume Next
Set xlsheet = Nothing
Set xlbook = Nothing
xlApp.Quit '<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Set xlApp = Nothing

'Shell "cmd /c c:\temp\test.xls"
End Sub

[rrenis]

Hi - Kenneth, I'll try using this approach and post back the results tomorrow. Thanks for taking the time to help me out. :bow:

Cheers,
rrenis

[rrenis]

Hi - I've tried stepping back a bit and running a stripped down version of the code that simply opens the excel spreadsheet and inserts some sample data and then closes it back down - without leaving excel.exe running in the process list (which is what is happening at the moment with MS Project). I've removed all references to MS Project tasks so it could be run from Word for example. The trouble is I get a subscript out of range error when trying to set the range. I'm sure it's something simple but having no luck resolving it. :banghead:

By the way if anyone can run this code without it leaving Excel running in the process list in task manager I'd be interested to hear it. Thanks.

Here's the code...

Option Explicit
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Sub TESTExportTasks()

Dim xlApp As Excel.Application 'NEW - Early Binding

Dim sRef As String
Dim Tasknumber As Integer

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = False
xlApp.ScreenUpdating = False
xlApp.DisplayAlerts = False

Dim Rng As Excel.Range ' NEW
Dim SheetName As String
Dim toDel As Excel.Range ' NEW

sRef = "TEST"
xlApp.Workbooks.Open "C:\Database.xls"
' I've altered the sheetname so that any new workbook named Database.xls in the C root will work for the test
Set Rng = xlApp.Worksheets("Sheet1").Range("A:A") ' Subscript Out of Range Error

' the following finds the existing reference in the excel spreadsheet and if found deletes it so that the new dates can be written
FindRef:
Set toDel = Rng.Find(sRef)
If toDel Is Nothing Then GoTo PasteData Else
Rng.Parent.Rows(toDel.Row).Delete
GoTo FindRef

PasteData:
Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
Set xlRow = xlApp.ActiveCell

' the following is specific to exporting the MS Project task dates to excel and is used to move onto the next column - I've left this in for the offset of the test data below
Tasknumber = 0

' INSERT TEST DATA
Set xlCol = xlRow.Offset(0, Tasknumber)
xlCol = "TEST"
Tasknumber = Tasknumber + 1
Set xlCol = xlRow.Offset(0, Tasknumber)
xlCol = "TEST 2"

ActiveWorkbook.Save ' NEW
ActiveWorkbook.Close False ' NEW

' everything below is pretty much left over from the MS Project, I don't think the problem lies here so have left it in

MYExit:

MsgBox "Data for project " & sRef & " has been successfully exported. ", , "Data Export"

GoTo MacroExit

Exit Sub

TaskError:

MsgBox "TEST not found", 0, "Faliure"

MacroExit:

On Error Resume Next
xlApp.Quit ' NEW
Set xlApp = Nothing ' NEW

Exit Sub

ErrorMessage:

MsgBox "An unexpected error has occurred." _
& vbCrLf & "Macro Name: ExportTasks" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MacroExit

End Sub
Sub dwn(i As Integer)
Set xlRow = xlRow.Offset(i, 0)
End Sub
Sub rgt(i As Integer)
Set xlCol = xlCol.Offset(0, i)
End Sub


Thanks for lookiong.

Cheers,
rrenis

[mdmackillop]

3 bugs
xlApp.Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
xlApp.ActiveWorkbook.Close False ' NEW
xlApp.ActiveWorkbook.Save ' NEW

Don't see why Excel is not closing!

[mdmackillop]

If you set
xlApp.Visible = True
then Excel is opened/closed in the Task Manager Applications window, but not in the Processes.

[rrenis]

Thanks Malcom, I've amended the code to rectify the 3 bugs you highlighted and also set xlApp.Visible = True but I'm still getting the subscript out of range error on the following line... :doh:

Set Rng = xlApp.Worksheets("Sheet1").Range("A:A")

Not sure why this is happening. I've tried running it from Word as there's no longer any references to task in this 'test' code' but U still get the same runtime error 9 problem. :dunno

Cheers,
rrenis

[mdmackillop]

The Visible = True was just to test what was happening. No need to change it.

[rrenis]

Thanks for the info Malcom - it'll be nice to leave it as false when (if) the code works : pray2:

cheers,
rrenis

[mdmackillop]

See also

http://support.microsoft.com/kb/899725


http://visualbasic.ittoolbox.com/groups/technical-functional/vb-vba-l/how-to-kill-an-excel-process-in-vb-6-application-2511509?cv=expanded

Reply from Lisa_Morgan (http://it.toolbox.com/people/lisa_morgan/) on 12/22/2008 8:16 AM
I seem to recall having this problem. It was a long time ago, but I fixed it by using late binding. Declare the object as a module-level object rather than an excel application.
Dim objXL as object
Then when you need to use it, inside your procedure, use
Set objXL=excel.Application

[rrenis]

Hi Malcom - thanks for digging out those links - interesting point about the com addin's (would never thought of that) - I only currently have the Analysis Toolpak ticked so will try unticking that - I guess I could disable it in VBA too? Will look into that once this code works.

Also thanks for posting the note from Lisa Morgan, I'll change the code to use late binding and see if that resolves things. Starting to feel a liitle more optomistic now - was about to start asking around for a hammer! :)

Cheers,
rrenis.

[rrenis]

Hi Malcom, Thanks again for your posts last week. I've amended the code to use late binding as attached below. I've also unticked all of the add-ins in Excel. Unfortunately it's still leaving excel running in the process list. I'm really at a loss as to why this is happening. :banghead:

I'd be interested to know if you have the same problem if you try running the code from MS Word or MS Project. :think:

Here's the revised code...

' References - Microsoft Scripting Runtime AND Microsoft Excel 11.0 Object Library
Option Explicit
Dim xlApp As Object
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
Sub ExportTEST()

Dim TaskNumber As Integer
Dim sRef As String
Dim NewApp As String
Dim myHeader As String

Set xlApp = Excel.Application

Dim Rng As Excel.Range
Dim SheetName As String
Dim toDel As Excel.Range

sRef = "TEST" 'Left(ActiveProject.Name, 5) ' get the project reference from the Project filename
SheetName = "Sheet1"
xlApp.Workbooks.Open FileName:="C:\Database.xls", UpdateLinks:=3 ' This sometimes causes a Run-time Error 462:
'The remote server machine does not exist or is unavailable (Not sure why??)

Sheets(SheetName).Select
Set Rng = xlApp.ActiveWorkbook.Worksheets(SheetName).Range("A:A")

' the following find the existing reference in the excel spreadsheet and if found deletes it so that the new dates can be written
FindRef:
Set toDel = Rng.Find(sRef)
If toDel Is Nothing Then GoTo PasteData Else
Rng.Parent.Rows(toDel.Row).Delete
GoTo FindRef

PasteData:
Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
Set xlRow = xlApp.ActiveCell

' the following is specific to exporting the MS Project task dates to excel
TaskNumber = 0

' INSERT TEST DATA
Set xlCol = xlRow.Offset(0, TaskNumber)
xlCol = "TEST"
TaskNumber = TaskNumber + 1
Set xlCol = xlRow.Offset(0, TaskNumber)
xlCol = "TEST 2"

xlApp.ActiveWorkbook.Save ' NEW
xlApp.ActiveWorkbook.Close ' False ' NEW

MsgBox "Data successfully exported. ", , "Test Data Export"

MacroExit:

xlApp.Quit ' NEW
Set xlRow = Nothing
Set xlCol = Nothing
Set Rng = Nothing
Set toDel = Nothing
Set xlApp = Nothing ' NEW

End Sub
Sub dwn(i As Integer)
Set xlRow = xlRow.Offset(i, 0)
End Sub
Sub rgt(i As Integer)
Set xlCol = xlCol.Offset(0, i)
End Sub


Thanks for looking :)

Cheers,
rrenis