Hi, I know little about VBA. Former employee wrote this code in 2003 but no
longer working in 2007 since 2007 dropped filesearch option.

Sub CombineFiles()

Application.DisplayAlerts = False
'On Error Resume Next

'declare variables
Dim FileCount As Long, FileNumber As Long, CurrFile As String
Dim myMacro As String, myNewFile As String, myFolder As String
Dim myFileRef As String

'assign values to variables
myMacro = ActiveWorkbook.Name
Application.Workbooks.Add
myNewFile = ActiveWorkbook.Name
Workbooks(myNewFile).Worksheets(1).Select
Range("a1").Select
myFileRef = Application.GetOpenFilename
Workbooks.Open Filename:=myFileRef
myFileRef = ActiveWorkbook.Name
myFolder = ActiveWorkbook.Path
ActiveWorkbook.Worksheets(1).Select
Range("a1").CurrentRegion.Rows(1).Copy
Workbooks(myNewFile).Activate
Range("b1").Select
ActiveSheet.Paste
Range("a1").Value = "File Name"
Range("b2").Select
Workbooks(myFileRef).Close False

'search for all Excel files in myFolder
With Application.FileSearch
.NewSearch
.LookIn = myFolder
.FileType = msoFileTypeExcelWorkbooks
.Execute
End With

'start loop to look inside each Excel file found
FileCount = Application.FileSearch.FoundFiles.Count
For FileNumber = 1 To FileCount
'give user status of macro while running
Application.StatusBar = "Searching " & FileNumber & " of " & FileCount &
" files."
'open file as read-only
Workbooks.Open Application.FileSearch.FoundFiles.Item(FileNumber) , ,
ReadOnly:=True
CurrFile = ActiveWorkbook.Name
Sheets(1).Select
Range("a1").Select
Selection.CurrentRegion.Copy
Workbooks(myNewFile).Activate
ActiveSheet.Paste
Selection.Rows(1).Delete
Selection.Columns(0).Value = CurrFile
Workbooks(CurrFile).Close False
Range("a1").Offset(Range("a1").CurrentRegion.Rows. Count - 1, 0).Select
ActiveCell.Delete
ActiveCell.Offset(0, 1).Select


NextFileNumber:
Next FileNumber

Range("a1").Select
Application.StatusBar = "Ready"

End Sub

What is the alternative way of fixing this?

Thanks for help!

This is no longer available in 2007.

'To loop through the files within a folder try the below code
Sub FileList()
Dim strFile As string, strFolder As string
strFolder = "c:\"

strFile = Dir(strFolder & "*.*", vbNormal)
Do While strFile < ""
MsgBox strFolder & strFile
strFile = Dir
Loop
End Sub

PS: You can use try FileSystemObject to loop through the files

--
Jacob


"GEORGIA" wrote:

Hi, I know little about VBA. Former employee wrote this code in 2003 but no
longer working in 2007 since 2007 dropped filesearch option.

Sub CombineFiles()

Application.DisplayAlerts = False
'On Error Resume Next

'declare variables
Dim FileCount As Long, FileNumber As Long, CurrFile As String
Dim myMacro As String, myNewFile As String, myFolder As String
Dim myFileRef As String

'assign values to variables
myMacro = ActiveWorkbook.Name
Application.Workbooks.Add
myNewFile = ActiveWorkbook.Name
Workbooks(myNewFile).Worksheets(1).Select
Range("a1").Select
myFileRef = Application.GetOpenFilename
Workbooks.Open Filename:=myFileRef
myFileRef = ActiveWorkbook.Name
myFolder = ActiveWorkbook.Path
ActiveWorkbook.Worksheets(1).Select
Range("a1").CurrentRegion.Rows(1).Copy
Workbooks(myNewFile).Activate
Range("b1").Select
ActiveSheet.Paste
Range("a1").Value = "File Name"
Range("b2").Select
Workbooks(myFileRef).Close False

'search for all Excel files in myFolder
With Application.FileSearch
.NewSearch
.LookIn = myFolder
.FileType = msoFileTypeExcelWorkbooks
.Execute
End With

'start loop to look inside each Excel file found
FileCount = Application.FileSearch.FoundFiles.Count
For FileNumber = 1 To FileCount
'give user status of macro while running
Application.StatusBar = "Searching " & FileNumber & " of " & FileCount &
" files."
'open file as read-only
Workbooks.Open Application.FileSearch.FoundFiles.Item(FileNumber) , ,
ReadOnly:=True
CurrFile = ActiveWorkbook.Name
Sheets(1).Select
Range("a1").Select
Selection.CurrentRegion.Copy
Workbooks(myNewFile).Activate
ActiveSheet.Paste
Selection.Rows(1).Delete
Selection.Columns(0).Value = CurrFile
Workbooks(CurrFile).Close False
Range("a1").Offset(Range("a1").CurrentRegion.Rows. Count - 1, 0).Select
ActiveCell.Delete
ActiveCell.Offset(0, 1).Select


NextFileNumber:
Next FileNumber

Range("a1").Select
Application.StatusBar = "Ready"

End Sub

What is the alternative way of fixing this?

Thanks for help!