MS Project (2007) VBA to Export to MS Excel (2010)

[tgabes18]

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

 

[andrewkard]

Hello, maybe:
SubFolder.Path & "\" & * & searchTerm & * & ".xls"

 

[tgabes18]

Thanks Andrew. I have played around with the wildcard * and did not find a resolution.

Any other thoughts?

 

[andrewkard]

Hello, maybe something like that:

Sub test()
Dim fso As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fso = fso.getfolder(ActiveWorkbook.Path)
For Each subfolder In fso.SubFolders
For Each file In subfolder.Files
If file.Name = searchTerm & "*.xls" Then
i = i + 1
strArr(i, 1) = subfolder.Path & "\" & file.Name
End If
Next
Next
End Sub