G
GEORGIA
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!
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!