All, I have the following code which worked in 2010 and I believe was prior to me upgrading my MS Office suite from 2007 to 2010. Might this be an issue between the application versions? When running the program, I get "Bad File Name or Number" run-time error which occurs on the second iteration of the bolded line in the subroutine (strName is null throughout). Thanks for your help or suggestions!
Sub Export_Macro2007()
' Macro Recorded Mon 6/24/10
'Created by Tim Gabel
'This macro is designed to export the open MS Project Plan to MS Excel and call upon a
'created Excel macro to format the tasks list
Set xlApp = CreateObject("Excel.Application")
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim personalBook As Excel.Workbook
Set xlBook = xlApp.Workbooks.Add
xlBook.Worksheets.Add
Dim fso As Object
Dim strName As String
Dim strArr(1 To 65536, 1 To 1) As String
Dim i As Long
Const strDir As String = "C:\"
Const searchTerm As String = "PERSONAL"
Let strName = Dir$(strDir & "\*" & searchTerm & "*.xls")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & "\" & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i, searchTerm)
Set fso = Nothing
If i > 0 Then
Set personalBook = xlApp.Workbooks.Open(strArr(i, 1))
Else
MsgBox ("PERSONAL.XLS book not found within C:\program files subfolders")
Exit Sub
End If
yesno = MsgBox("Create a new report? Click Yes. To add to existing workbook, Click No.", vbYesNoCancel, "Create Report")
If yesno = vbCancel Then
Exit Sub
End If
'Select and Copy anything that is shown on the current view of the project plan
SelectSheet
EditCopy
xlApp.Visible = True
If yesno = vbYes Then
Set xlBook = xlApp.Workbooks.Add
xlApp.Dialogs(xlDialogSaveAs).Show
FileName = xlBook.Name
xlBook.ActiveSheet.Paste
xlApp.Run ("PERSONAL.XLS!Name_of_Macro")
xlBook.Save
Else
'Open an existing workbook, paste the copied tasks, and run the
'project customized Excel created formatting macro
strFile = xlApp.GetOpenFileName
Set xlBook = xlApp.Workbooks.Open(strFile)
xlBook.Worksheets.Add
xlBook.ActiveSheet.Paste
xlApp.Run ("PERSONAL.XLS!Name_of_Macro")
xlBook.Save
End If
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, ByRef strArr() As String, ByRef i As Long, ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\*" & searchTerm & "*.xls")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next
End Sub
Sub Export_Macro2007()
' Macro Recorded Mon 6/24/10
'Created by Tim Gabel
'This macro is designed to export the open MS Project Plan to MS Excel and call upon a
'created Excel macro to format the tasks list
Set xlApp = CreateObject("Excel.Application")
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim personalBook As Excel.Workbook
Set xlBook = xlApp.Workbooks.Add
xlBook.Worksheets.Add
Dim fso As Object
Dim strName As String
Dim strArr(1 To 65536, 1 To 1) As String
Dim i As Long
Const strDir As String = "C:\"
Const searchTerm As String = "PERSONAL"
Let strName = Dir$(strDir & "\*" & searchTerm & "*.xls")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & "\" & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i, searchTerm)
Set fso = Nothing
If i > 0 Then
Set personalBook = xlApp.Workbooks.Open(strArr(i, 1))
Else
MsgBox ("PERSONAL.XLS book not found within C:\program files subfolders")
Exit Sub
End If
yesno = MsgBox("Create a new report? Click Yes. To add to existing workbook, Click No.", vbYesNoCancel, "Create Report")
If yesno = vbCancel Then
Exit Sub
End If
'Select and Copy anything that is shown on the current view of the project plan
SelectSheet
EditCopy
xlApp.Visible = True
If yesno = vbYes Then
Set xlBook = xlApp.Workbooks.Add
xlApp.Dialogs(xlDialogSaveAs).Show
FileName = xlBook.Name
xlBook.ActiveSheet.Paste
xlApp.Run ("PERSONAL.XLS!Name_of_Macro")
xlBook.Save
Else
'Open an existing workbook, paste the copied tasks, and run the
'project customized Excel created formatting macro
strFile = xlApp.GetOpenFileName
Set xlBook = xlApp.Workbooks.Open(strFile)
xlBook.Worksheets.Add
xlBook.ActiveSheet.Paste
xlApp.Run ("PERSONAL.XLS!Name_of_Macro")
xlBook.Save
End If
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, ByRef strArr() As String, ByRef i As Long, ByRef searchTerm As String)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\*" & searchTerm & "*.xls")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i, searchTerm)
Next
End Sub