Opening an Excel Worksheet from Project yields an empty project... 90%of the time!

C

Craig Remillard

Cross-posted in the Excel group.

I wrote a subroutine in an Excel 2007 module which builds a map using MapEdit and calls the Application.FileOpenEx method from MS Project to import a worksheet. The pertinent code is:

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True, _
DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName, _
FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks", _
ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, _
TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name", _
ExternalFieldName:="Task Name"

****several lines of similar syntax here****

MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost", ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0, FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"

--------------------------------------
The code worked flawlessly all yesterday when I was operating on a worksheet that is in my Excel workbook file. However, I wanted to generalize things so I could have multiple header rows.

So I wrote another subroutine which creates a temporary worksheet and copies the pertinent data to it in such a way that Project can open it, with a single header row and data in columns below.

Now, the code only works intermittently. By which I mean, about one out of ten or one out of twenty times. I have tried to isolate the problem. I thought it might be the Copy subroutine, so I manually copied the data to a sheet with the same name as the temporary sheet and ran it. Still works only intermittently. I had a user form called earlier in the subroutine, but I shut it off with a boolean if statement switch.

I get no error statement. The problem occurs regardless of whether I call the subroutine from the VBE or use a button control. It occurs whether Project is open or not when I initialize the subroutine, and whether there is an existing version of the .mpp file or not. One thing I have observed is that, when I make a seemingly unrelated change in the code, it is more likely to work correctly. I have no idea how to explain this. Any ideas? I have pasted the full code below. Thanks.

-------------------------

Option Explicit

Public Sub X2P()

Dim prj, chk As Object
Dim WBSStartCell As Range
Dim TmpWSName, WBSWSName, PrjPath, PrjXtn, PrjName, BkpFldr, BkpSfx, SrcFile, DestFile As String
Dim DnT As Date
Dim Bkp, AutoBkp, XSub As Boolean
Dim NShts, i As Integer
Dim TempWksht As Worksheet

'Application.ActivateMicrosoftApp (xlMicrosoftProject)
Set prj = CreateObject("MSProject.Application")
prj.Visible = True

PrjPath = "C:\_THESIS\Data\TestProj\"
PrjName = "Test"
PrjXtn = ".mpp"
BkpFldr = "Old Production Plans"
TmpWSName = "XXXWBSTEMPXXX"

AutoBkp = True 'if true, suppresses dialog box that asks for backup suffix
Bkp = True 'if true, backs up existing Test.mpp file
XSub = False

WBSWSName = "To Project" 'ActiveSheet.Name

With prj

'Save & close the current version of Test.mpp if it exists
i = 1
For Each chk In Projects
If Projects(i).Name = PrjName & PrjXtn Then
Projects(i).Activate
FileClose Save:=pjSave
Exit For
End If
i = i + 1
Next chk

End With

'sub copies desired columns from WBS worksheet into a temp worksheet
Call Cols2XSht(TmpWSName, WBSWSName)

'If there is a Project with the PrjName in the PrjPath folder,
'back it up and delete the original
If Not Dir(PrjPath & PrjName & PrjXtn, vbNormal) = "" Then

'Opens alert box if auto-backup not enabled
If Not AutoBkp Then
BackupOptionsBox.Show
Bkp = BackupOptionsBox.YesOption
BkpSfx = "_" & BackupOptionsBox.SfxBox.Value
XSub = BackupOptionsBox.CancelButton.Value
Unload BackupOptionsBox
Debug.Print ("Yes=" & Bkp & ", No=" & BackupOptionsBox.NoOption & ", XSub=" & XSub)
'Drop out of sub if cancel button was pushed
If XSub Then
prj.FileOpenEx Name:=PrjName & PrjXtn
Exit Sub
End If
Else
BkpSfx = "_" & Format(Now(), "yyyymmdd_HHmmss")
End If

SrcFile = PrjPath & PrjName & PrjXtn

'Backup the current MPP file in another directory with a suffix
If Bkp Then
If Dir(PrjPath & BkpFldr, vbDirectory) = "" Then
MkDir (PrjPath & BkpFldr)
End If

'Save a copy of the just-closed MPP file to the BkpFldr
'with a date/time stamp in the filename
DestFile = PrjPath & BkpFldr & "\" & PrjName & BkpSfx & PrjXtn
FileCopy SrcFile, DestFile
End If

'delete the original file
Kill (SrcFile)
End If

Worksheets(TmpWSName).Activate

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True, DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName, FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks", ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name", ExternalFieldName:="Task Name"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration", ExternalFieldName:="Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Total Slack", ExternalFieldName:="Slack"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Predecessors", ExternalFieldName:="Predecessors"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Start", ExternalFieldName:="Start"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Finish", ExternalFieldName:="Finish"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="WBS", ExternalFieldName:="WBS"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Resource Names", ExternalFieldName:="HResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text1", ExternalFieldName:="Space"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text2", ExternalFieldName:="XResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration1", ExternalFieldName:="Opt Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration2", ExternalFieldName:="Pess Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost", ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
'Application.DisplayAlerts = False
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0, FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"
'Application.DisplayAlerts = True

'Format the task table in Project
TableEdit Name:="LynxWBS", TaskTable:=True, Create:=True, OverwriteExisting:=True, FieldName:="ID", Title:="", Width:=4, Align:=2, ShowInMenu:=False, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="WBS", Title:="", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Name", Title:="", Width:=25, Align:=pjLeft, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Total Slack", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Predecessors", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Resource Names", Title:="", Width:=20, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text1", Title:="Space", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text2", Title:="XResources", Width:=16, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Start", Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Finish", Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration1", Title:="Opt Duration", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration2", Title:="Pess Duration", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Cost", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableApply Name:="LynxWBS"
End With

Debug.Print (Worksheets(TmpWSName).Cells(1, 1).Value)

'Delete temp worksheet
Call DeleteWS(TmpWSName)
Worksheets(WBSWSName).Activate

Exit Sub

'This is a loop for the run-time error, in hopes
'that eventually the server responds
ErrorChk:
If Err.Number = 462 And j < 1001 Then
j = j + 1
GoTo TryAgain
Else
Resume
End If

End Sub


Private Sub Cols2XSht(ByVal TmpWSName As String, ByVal FromSheet As String)
'Insert a new worksheet and copy the important columns

Dim NShts, DestCol As Integer
Dim ColRange, StartCell, EndCell, CurCol, CurColEnd, CurHdrCell As Range
Dim CurBool, WS As Object
Dim TmpWSExists As Boolean

TmpWSExists = False

ThisWorkbook.Activate
Worksheets(1).Activate

'Check that the temporary worksheet does not already exist
For Each WS In ActiveWorkbook.Worksheets
'Debug.Print (WS.Name)
If WS.Name = TmpWSName Then
TmpWSExists = True
'Debug.Print ("ws exists")
Exit For
End If
Next WS


'Make a new temp worksheet to copy the columns that will transfer to Project
If Not TmpWSExists Then
NShts = Worksheets.Count
'Debug.Print (NShts)
Worksheets.Add(After:=Worksheets(NShts)).Name = TmpWSName
End If

'Clear the temp worksheet cells
Worksheets(TmpWSName).Cells.Clear

'Activate the WBS worksheet, start at the upper left corner
Worksheets(FromSheet).Activate
Set StartCell = ActiveSheet.Cells(1, 1)
StartCell.Activate

'Find the flag cell in the first column that denotes the boolean header row
Do Until StartCell.Value = "PrjVar?" Or StartCell.Row = 10
Set StartCell = ActiveSheet.Cells(StartCell.Row + 1, StartCell.Column)
'Debug.Print (StartCell.Row & "," & StartCell.Column & "; " & StartCell.Value)
Loop

'Set the start and end cell of the headers range
Set StartCell = ActiveSheet.Cells(StartCell.Row, StartCell.Column + 1)
Set EndCell = ActiveSheet.Cells(StartCell.Row, 256)
Set ColRange = Range(StartCell, EndCell)

DestCol = 1
'Loop through all the column boolean headers
For Each CurBool In ColRange.Cells

'If a boolean header is 1, copy the column into the temp worksheet
If CurBool.Value = 1 Then
Set CurHdrCell = ActiveSheet.Cells(CurBool.Row + 1, CurBool.Column)
Set CurColEnd = ActiveSheet.Cells(10000, CurBool.Column)
Set CurCol = Range(CurHdrCell, CurColEnd)
CurCol.Select
CurCol.Copy Destination:=Worksheets(TmpWSName).Cells(1, DestCol)
DestCol = DestCol + 1
End If

Next CurBool
End Sub

Private Sub DeleteWS(ByVal WS As String)

Application.DisplayAlerts = False
Worksheets(WS).Delete
Application.DisplayAlerts = False

End Sub

EggHeadCafe - Software Developer Portal of Choice
Dr. Dotnetsky's Cool .NET Tips & Tricks #15
http://www.eggheadcafe.com/tutorial...99a4-d74c89548125/dr-dotnetskys-cool-net.aspx
 
C

Craig Remillard

Unlike export, the FileOpenEx reads the saved version of the file, not the version in memory. I fixed the problem by using ThisWorkbook.SaveCopyAs. Then I opened the copy in Project and deleted the copy when I was done.



Craig Remillard wrote:

Opening an Excel Worksheet from Project yields an empty project... 90% of the time!
18-Nov-09

Cross-posted in the Excel group.

I wrote a subroutine in an Excel 2007 module which builds a map using MapEdit and calls the Application.FileOpenEx method from MS Project to import a worksheet. The pertinent code is:

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True, _
DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName, _
FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks", _
ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, _
TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name", _
ExternalFieldName:="Task Name"

****several lines of similar syntax here****

MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost", ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0, FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"

--------------------------------------
The code worked flawlessly all yesterday when I was operating on a worksheet that is in my Excel workbook file. However, I wanted to generalize things so I could have multiple header rows.

So I wrote another subroutine which creates a temporary worksheet and copies the pertinent data to it in such a way that Project can open it, with a single header row and data in columns below.

Now, the code only works intermittently. By which I mean, about one out of ten or one out of twenty times. I have tried to isolate the problem. I thought it might be the Copy subroutine, so I manually copied the data to a sheet with the same name as the temporary sheet and ran it. Still works only intermittently. I had a user form called earlier in the subroutine, but I shut it off with a boolean if statement switch.

I get no error statement. The problem occurs regardless of whether I call the subroutine from the VBE or use a button control. It occurs whether Project is open or not when I initialize the subroutine, and whether there is an existing version of the .mpp file or not. One thing I have observed is that, when I make a seemingly unrelated change in the code, it is more likely to work correctly. I have no idea how to explain this. Any ideas? I have pasted the full code below. Thanks.

-------------------------

Option Explicit

Public Sub X2P()

Dim prj, chk As Object
Dim WBSStartCell As Range
Dim TmpWSName, WBSWSName, PrjPath, PrjXtn, PrjName, BkpFldr, BkpSfx, SrcFile, DestFile As String
Dim DnT As Date
Dim Bkp, AutoBkp, XSub As Boolean
Dim NShts, i As Integer
Dim TempWksht As Worksheet

'Application.ActivateMicrosoftApp (xlMicrosoftProject)
Set prj = CreateObject("MSProject.Application")
prj.Visible = True

PrjPath = "C:\_THESIS\Data\TestProj\"
PrjName = "Test"
PrjXtn = ".mpp"
BkpFldr = "Old Production Plans"
TmpWSName = "XXXWBSTEMPXXX"

AutoBkp = True 'if true, suppresses dialog box that asks for backup suffix
Bkp = True 'if true, backs up existing Test.mpp file
XSub = False

WBSWSName = "To Project" 'ActiveSheet.Name

With prj

'Save & close the current version of Test.mpp if it exists
i = 1
For Each chk In Projects
If Projects(i).Name = PrjName & PrjXtn Then
Projects(i).Activate
FileClose Save:=pjSave
Exit For
End If
i = i + 1
Next chk

End With

'sub copies desired columns from WBS worksheet into a temp worksheet
Call Cols2XSht(TmpWSName, WBSWSName)

'If there is a Project with the PrjName in the PrjPath folder,
'back it up and delete the original
If Not Dir(PrjPath & PrjName & PrjXtn, vbNormal) = "" Then

'Opens alert box if auto-backup not enabled
If Not AutoBkp Then
BackupOptionsBox.Show
Bkp = BackupOptionsBox.YesOption
BkpSfx = "_" & BackupOptionsBox.SfxBox.Value
XSub = BackupOptionsBox.CancelButton.Value
Unload BackupOptionsBox
Debug.Print ("Yes=" & Bkp & ", No=" & BackupOptionsBox.NoOption & ", XSub=" & XSub)
'Drop out of sub if cancel button was pushed
If XSub Then
prj.FileOpenEx Name:=PrjName & PrjXtn
Exit Sub
End If
Else
BkpSfx = "_" & Format(Now(), "yyyymmdd_HHmmss")
End If

SrcFile = PrjPath & PrjName & PrjXtn

'Backup the current MPP file in another directory with a suffix
If Bkp Then
If Dir(PrjPath & BkpFldr, vbDirectory) = "" Then
MkDir (PrjPath & BkpFldr)
End If

'Save a copy of the just-closed MPP file to the BkpFldr
'with a date/time stamp in the filename
DestFile = PrjPath & BkpFldr & "\" & PrjName & BkpSfx & PrjXtn
FileCopy SrcFile, DestFile
End If

'delete the original file
Kill (SrcFile)
End If

Worksheets(TmpWSName).Activate

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True, DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName, FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks", ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False, IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name", ExternalFieldName:="Task Name"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration", ExternalFieldName:="Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Total Slack", ExternalFieldName:="Slack"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Predecessors", ExternalFieldName:="Predecessors"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Start", ExternalFieldName:="Start"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Finish", ExternalFieldName:="Finish"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="WBS", ExternalFieldName:="WBS"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Resource Names", ExternalFieldName:="HResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text1", ExternalFieldName:="Space"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text2", ExternalFieldName:="XResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration1", ExternalFieldName:="Opt Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration2", ExternalFieldName:="Pess Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost", ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
'Application.DisplayAlerts = False
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0, FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"
'Application.DisplayAlerts = True

'Format the task table in Project
TableEdit Name:="LynxWBS", TaskTable:=True, Create:=True, OverwriteExisting:=True, FieldName:="ID", Title:="", Width:=4, Align:=2, ShowInMenu:=False, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="WBS", Title:="", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Name", Title:="", Width:=25, Align:=pjLeft, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Total Slack", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Predecessors", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Resource Names", Title:="", Width:=20, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text1", Title:="Space", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text2", Title:="XResources", Width:=16, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Start", Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Finish", Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration1", Title:="Opt Duration", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration2", Title:="Pess Duration", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Cost", Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableApply Name:="LynxWBS"
End With

Debug.Print (Worksheets(TmpWSName).Cells(1, 1).Value)

'Delete temp worksheet
Call DeleteWS(TmpWSName)
Worksheets(WBSWSName).Activate

Exit Sub

'This is a loop for the run-time error, in hopes
'that eventually the server responds
ErrorChk:
If Err.Number = 462 And j < 1001 Then
j = j + 1
GoTo TryAgain
Else
Resume
End If

End Sub


Private Sub Cols2XSht(ByVal TmpWSName As String, ByVal FromSheet As String)
'Insert a new worksheet and copy the important columns

Dim NShts, DestCol As Integer
Dim ColRange, StartCell, EndCell, CurCol, CurColEnd, CurHdrCell As Range
Dim CurBool, WS As Object
Dim TmpWSExists As Boolean

TmpWSExists = False

ThisWorkbook.Activate
Worksheets(1).Activate

'Check that the temporary worksheet does not already exist
For Each WS In ActiveWorkbook.Worksheets
'Debug.Print (WS.Name)
If WS.Name = TmpWSName Then
TmpWSExists = True
'Debug.Print ("ws exists")
Exit For
End If
Next WS


'Make a new temp worksheet to copy the columns that will transfer to Project
If Not TmpWSExists Then
NShts = Worksheets.Count
'Debug.Print (NShts)
Worksheets.Add(After:=Worksheets(NShts)).Name = TmpWSName
End If

'Clear the temp worksheet cells
Worksheets(TmpWSName).Cells.Clear

'Activate the WBS worksheet, start at the upper left corner
Worksheets(FromSheet).Activate
Set StartCell = ActiveSheet.Cells(1, 1)
StartCell.Activate

'Find the flag cell in the first column that denotes the boolean header row
Do Until StartCell.Value = "PrjVar?" Or StartCell.Row = 10
Set StartCell = ActiveSheet.Cells(StartCell.Row + 1, StartCell.Column)
'Debug.Print (StartCell.Row & "," & StartCell.Column & "; " & StartCell.Value)
Loop

'Set the start and end cell of the headers range
Set StartCell = ActiveSheet.Cells(StartCell.Row, StartCell.Column + 1)
Set EndCell = ActiveSheet.Cells(StartCell.Row, 256)
Set ColRange = Range(StartCell, EndCell)

DestCol = 1
'Loop through all the column boolean headers
For Each CurBool In ColRange.Cells

'If a boolean header is 1, copy the column into the temp worksheet
If CurBool.Value = 1 Then
Set CurHdrCell = ActiveSheet.Cells(CurBool.Row + 1, CurBool.Column)
Set CurColEnd = ActiveSheet.Cells(10000, CurBool.Column)
Set CurCol = Range(CurHdrCell, CurColEnd)
CurCol.Select
CurCol.Copy Destination:=Worksheets(TmpWSName).Cells(1, DestCol)
DestCol = DestCol + 1
End If

Next CurBool
End Sub

Private Sub DeleteWS(ByVal WS As String)

Application.DisplayAlerts = False
Worksheets(WS).Delete
Application.DisplayAlerts = False

End Sub

Previous Posts In This Thread:

EggHeadCafe - Software Developer Portal of Choice
HANDLING BINARY AND TEXT DATA IN XML OVER THE WIRE
http://www.eggheadcafe.com/tutorial...71-c05dd05ba1fd/handling-binary-and-text.aspx
 
R

Rod Gill

HI,

No obvious culprit that I can see, but a number of bad coding practices that
are very likely to cause undesirable problems.

Code is much easier to read and debug when you set a reference and use
variable names that reflect what they do.

CreateObject for Excel works every time because you can have multiple copies
of Excel running. You can only have one copy of project. So I would add a
reference to MSProject library under Tools, References in Excel VBE. then
code the first part as:

Dim prjApp As MSProject.Application
Dim proj As MSProject.Project
Dim WBSStartCell As Range
Dim TmpWSName, WBSWSName, PrjPath, PrjXtn, PrjName, BkpFldr, BkpSfx,
SrcFile, DestFile As String
Dim DnT As Date
Dim Bkp, AutoBkp, XSub As Boolean
Dim NShts, i As Integer
Dim TempWksht As Worksheet

'Application.ActivateMicrosoftApp (xlMicrosoftProject)
On Error Resume Next
Set prjApp = GetObject(, "MSProject.Application")
If prjApp Is Nothing Then
Set prjApp = CreateObject("MSProject.Application")
End If
prjApp.Visible = True

PrjPath = "C:\_THESIS\Data\TestProj\"
PrjName = "Test"
PrjXtn = ".mpp"
BkpFldr = "Old Production Plans"
TmpWSName = "XXXWBSTEMPXXX"

AutoBkp = True 'if true, suppresses dialog box that asks for backup
suffix
Bkp = True 'if true, backs up existing Test.mpp file
XSub = False

WBSWSName = "To Project" 'ActiveSheet.Name

With prjApp
Err.Clear
Projects(PrjName & PrjXtn).Activate
If Err = 0 Then 'If project found
FileClose Save:=pjSave
End If
End With

Your For Each chk In Projects statement needs to be:
For Each proj In prjApp.Projects

--

Rod Gill
Microsoft MVP for Project

Author of the only book on Project VBA, see:
http://www.projectvbabook.com




in message
Cross-posted in the Excel group.

I wrote a subroutine in an Excel 2007 module which builds a map using
MapEdit and calls the Application.FileOpenEx method from MS Project to
import a worksheet. The pertinent code is:

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True, _
DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName, _
FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks", _
ImportMethod:=0, HeaderRow:=True, AssignmentData:=False, _
TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False,
IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name", _
ExternalFieldName:="Task Name"

****several lines of similar syntax here****

MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost",
ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0,
FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"

--------------------------------------
The code worked flawlessly all yesterday when I was operating on a
worksheet that is in my Excel workbook file. However, I wanted to
generalize things so I could have multiple header rows.

So I wrote another subroutine which creates a temporary worksheet and
copies the pertinent data to it in such a way that Project can open it,
with a single header row and data in columns below.

Now, the code only works intermittently. By which I mean, about one out
of ten or one out of twenty times. I have tried to isolate the problem.
I thought it might be the Copy subroutine, so I manually copied the data
to a sheet with the same name as the temporary sheet and ran it. Still
works only intermittently. I had a user form called earlier in the
subroutine, but I shut it off with a boolean if statement switch.

I get no error statement. The problem occurs regardless of whether I call
the subroutine from the VBE or use a button control. It occurs whether
Project is open or not when I initialize the subroutine, and whether there
is an existing version of the .mpp file or not. One thing I have observed
is that, when I make a seemingly unrelated change in the code, it is more
likely to work correctly. I have no idea how to explain this. Any ideas?
I have pasted the full code below. Thanks.

-------------------------

Option Explicit

Public Sub X2P()

Dim prj, chk As Object
Dim WBSStartCell As Range
Dim TmpWSName, WBSWSName, PrjPath, PrjXtn, PrjName, BkpFldr, BkpSfx,
SrcFile, DestFile As String
Dim DnT As Date
Dim Bkp, AutoBkp, XSub As Boolean
Dim NShts, i As Integer
Dim TempWksht As Worksheet

'Application.ActivateMicrosoftApp (xlMicrosoftProject)
Set prj = CreateObject("MSProject.Application")
prj.Visible = True

PrjPath = "C:\_THESIS\Data\TestProj\"
PrjName = "Test"
PrjXtn = ".mpp"
BkpFldr = "Old Production Plans"
TmpWSName = "XXXWBSTEMPXXX"

AutoBkp = True 'if true, suppresses dialog box that asks for backup
suffix
Bkp = True 'if true, backs up existing Test.mpp file
XSub = False

WBSWSName = "To Project" 'ActiveSheet.Name

With prj

'Save & close the current version of Test.mpp if it exists
i = 1
For Each chk In Projects
If Projects(i).Name = PrjName & PrjXtn Then
Projects(i).Activate
FileClose Save:=pjSave
Exit For
End If
i = i + 1
Next chk

End With

'sub copies desired columns from WBS worksheet into a temp worksheet
Call Cols2XSht(TmpWSName, WBSWSName)

'If there is a Project with the PrjName in the PrjPath folder,
'back it up and delete the original
If Not Dir(PrjPath & PrjName & PrjXtn, vbNormal) = "" Then

'Opens alert box if auto-backup not enabled
If Not AutoBkp Then
BackupOptionsBox.Show
Bkp = BackupOptionsBox.YesOption
BkpSfx = "_" & BackupOptionsBox.SfxBox.Value
XSub = BackupOptionsBox.CancelButton.Value
Unload BackupOptionsBox
Debug.Print ("Yes=" & Bkp & ", No=" & BackupOptionsBox.NoOption &
", XSub=" & XSub)
'Drop out of sub if cancel button was pushed
If XSub Then
prj.FileOpenEx Name:=PrjName & PrjXtn
Exit Sub
End If
Else
BkpSfx = "_" & Format(Now(), "yyyymmdd_HHmmss")
End If

SrcFile = PrjPath & PrjName & PrjXtn

'Backup the current MPP file in another directory with a suffix
If Bkp Then
If Dir(PrjPath & BkpFldr, vbDirectory) = "" Then
MkDir (PrjPath & BkpFldr)
End If

'Save a copy of the just-closed MPP file to the BkpFldr
'with a date/time stamp in the filename
DestFile = PrjPath & BkpFldr & "\" & PrjName & BkpSfx & PrjXtn
FileCopy SrcFile, DestFile
End If

'delete the original file
Kill (SrcFile)
End If

Worksheets(TmpWSName).Activate

With prj

'Debug.Print ("inprj")
'Create mapping of column headers to task categories
MapEdit Name:="X2P_Tasks", Create:=True, OverwriteExisting:=True,
DataCategory:=0, CategoryEnabled:=True, TableName:=TmpWSName,
FieldName:="ID", ExternalFieldName:="ID", ExportFilter:="All Tasks",
ImportMethod:=0, HeaderRow:=True, AssignmentData:=False,
TextDelimiter:=Chr$(9), TextFileOrigin:=0, UseHtmlTemplate:=False,
IncludeImage:=False
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Name",
ExternalFieldName:="Task Name"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration",
ExternalFieldName:="Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Total Slack",
ExternalFieldName:="Slack"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Predecessors",
ExternalFieldName:="Predecessors"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Start",
ExternalFieldName:="Start"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Finish",
ExternalFieldName:="Finish"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="WBS",
ExternalFieldName:="WBS"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Resource
Names", ExternalFieldName:="HResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text1",
ExternalFieldName:="Space"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Text2",
ExternalFieldName:="XResources"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration1",
ExternalFieldName:="Opt Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Duration2",
ExternalFieldName:="Pess Duration"
MapEdit Name:="X2P_Tasks", DataCategory:=0, FieldName:="Cost",
ExternalFieldName:="Cost"

'Open Excel WBS sheet in Project, then save as MS Project file
'Application.DisplayAlerts = False
FileOpenEx Name:=PrjPath & "TestProj.xls", ReadOnly:=False, Merge:=0,
FormatID:="MSProject.XLS8", Map:="X2P_Tasks"
FileSaveAs Name:=PrjPath & PrjName & PrjXtn, FormatID:="MSProject.MPP"
'Application.DisplayAlerts = True

'Format the task table in Project
TableEdit Name:="LynxWBS", TaskTable:=True, Create:=True,
OverwriteExisting:=True, FieldName:="ID", Title:="", Width:=4, Align:=2,
ShowInMenu:=False, LockFirstColumn:=True, DateFormat:=255, RowHeight:=1,
AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="WBS",
Title:="", Width:=10, Align:=2, LockFirstColumn:=True, DateFormat:=255,
RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Name",
Title:="", Width:=25, Align:=pjLeft, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration",
Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255,
RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Total
Slack", Title:="", Width:=8, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True,
NewFieldName:="Predecessors", Title:="", Width:=8, Align:=2,
LockFirstColumn:=True, DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Resource
Names", Title:="", Width:=20, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text1",
Title:="Space", Width:=10, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Text2",
Title:="XResources", Width:=16, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Start",
Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255,
RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Finish",
Title:="", Width:=12, Align:=2, LockFirstColumn:=True, DateFormat:=255,
RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration1",
Title:="Opt Duration", Width:=8, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Duration2",
Title:="Pess Duration", Width:=8, Align:=2, LockFirstColumn:=True,
DateFormat:=255, RowHeight:=1, AlignTitle:=1,
HeaderAutoRowHeightAdjustment:=False
TableEdit Name:="LynxWBS", TaskTable:=True, NewFieldName:="Cost",
Title:="", Width:=8, Align:=2, LockFirstColumn:=True, DateFormat:=255,
RowHeight:=1, AlignTitle:=1, HeaderAutoRowHeightAdjustment:=False
TableApply Name:="LynxWBS"
End With

Debug.Print (Worksheets(TmpWSName).Cells(1, 1).Value)

'Delete temp worksheet
Call DeleteWS(TmpWSName)
Worksheets(WBSWSName).Activate

Exit Sub

'This is a loop for the run-time error, in hopes
'that eventually the server responds
ErrorChk:
If Err.Number = 462 And j < 1001 Then
j = j + 1
GoTo TryAgain
Else
Resume
End If

End Sub


Private Sub Cols2XSht(ByVal TmpWSName As String, ByVal FromSheet As
String)
'Insert a new worksheet and copy the important columns

Dim NShts, DestCol As Integer
Dim ColRange, StartCell, EndCell, CurCol, CurColEnd, CurHdrCell As
Range
Dim CurBool, WS As Object
Dim TmpWSExists As Boolean

TmpWSExists = False

ThisWorkbook.Activate
Worksheets(1).Activate

'Check that the temporary worksheet does not already exist
For Each WS In ActiveWorkbook.Worksheets
'Debug.Print (WS.Name)
If WS.Name = TmpWSName Then
TmpWSExists = True
'Debug.Print ("ws exists")
Exit For
End If
Next WS


'Make a new temp worksheet to copy the columns that will transfer to
Project
If Not TmpWSExists Then
NShts = Worksheets.Count
'Debug.Print (NShts)
Worksheets.Add(After:=Worksheets(NShts)).Name = TmpWSName
End If

'Clear the temp worksheet cells
Worksheets(TmpWSName).Cells.Clear

'Activate the WBS worksheet, start at the upper left corner
Worksheets(FromSheet).Activate
Set StartCell = ActiveSheet.Cells(1, 1)
StartCell.Activate

'Find the flag cell in the first column that denotes the boolean header
row
Do Until StartCell.Value = "PrjVar?" Or StartCell.Row = 10
Set StartCell = ActiveSheet.Cells(StartCell.Row + 1,
StartCell.Column)
'Debug.Print (StartCell.Row & "," & StartCell.Column & "; " &
StartCell.Value)
Loop

'Set the start and end cell of the headers range
Set StartCell = ActiveSheet.Cells(StartCell.Row, StartCell.Column + 1)
Set EndCell = ActiveSheet.Cells(StartCell.Row, 256)
Set ColRange = Range(StartCell, EndCell)

DestCol = 1
'Loop through all the column boolean headers
For Each CurBool In ColRange.Cells

'If a boolean header is 1, copy the column into the temp worksheet
If CurBool.Value = 1 Then
Set CurHdrCell = ActiveSheet.Cells(CurBool.Row + 1,
CurBool.Column)
Set CurColEnd = ActiveSheet.Cells(10000, CurBool.Column)
Set CurCol = Range(CurHdrCell, CurColEnd)
CurCol.Select
CurCol.Copy Destination:=Worksheets(TmpWSName).Cells(1,
DestCol)
DestCol = DestCol + 1
End If

Next CurBool
End Sub

Private Sub DeleteWS(ByVal WS As String)

Application.DisplayAlerts = False
Worksheets(WS).Delete
Application.DisplayAlerts = False

End Sub

EggHeadCafe - Software Developer Portal of Choice
Dr. Dotnetsky's Cool .NET Tips & Tricks #15
http://www.eggheadcafe.com/tutorial...99a4-d74c89548125/dr-dotnetskys-cool-net.aspx

__________ Information from ESET Smart Security, version of virus
signature database 4621 (20091119) __________

The message was checked by ESET Smart Security.

http://www.eset.com
Click to expand...

__________ Information from ESET Smart Security, version of virus signature database 4621 (20091119) __________

The message was checked by ESET Smart Security.

http://www.eset.com
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Setting Workgroup To None with Macro 7
Loop question 3
Issues while creating an addin on MS Project 0
Controlling Microsoft Project from Excel 1
Renamed columns missing in insert column option in MS Project 4
Issues while creating an addin on MS Project 1
Identify if Summary and note in another column 27
Autorun question 6

Top