Code Error Excel 2007

[Mtaylorlc]

I have the code below set up in a macro I used a few years back and am trying to use again in excel 2007. It seems to be getting hung up on the following line:

Set FS = Application.FileSearch

The purpose of the workbook is to find all excel files in the same folder as this workbook, open, copy information, paste it in the "master document", and close each one at a time.

Your help is appreciated!



Private Sub cmdUpdate_Click()
Dim FS, i
Dim PlaceRow As Long
Dim OpenedName As String
Dim DoNotReopenActiveWB_Name As String
Dim DataBook As String

Sheet1.Range("A2:AF1000").ClearContents
Sheet1.Range("BA1:BA1000").ClearContents
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
DoNotReopenActiveWB_Name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
DataBook = ActiveWorkbook.Name
PlaceRow = 1
Debug.Print DoNotReopenActiveWB_Name
Set FS = Application.FileSearch
With FS
.LookIn = ActiveWorkbook.Path
.Filename = "*.XLS"
If .Execute Then
For i = 1 To .FoundFiles.Count
If .FoundFiles(i) <> DoNotReopenActiveWB_Name Then
PlaceRow = PlaceRow + 1
Workbooks.Open .FoundFiles(i)
OpenedName = ActiveWorkbook.Name
Workbooks(DataBook).Sheets("Table1") _
.Range("A" & PlaceRow & ":AF" & PlaceRow).Value = _
Workbooks(OpenedName).Sheets("Sheet1") _
.Range("A114:AF114").Value
Workbooks(DataBook).Sheets("Table1") _
.Range("BA" & PlaceRow).Value = .FoundFiles(i)
Workbooks(OpenedName).Close savechanges:=False
End If
Next i
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[wigi]

Application.FileSearch is deprecated in Excel 2007. You should use Dir.

A very recent example with code can be found here:

http://www.mrexcel.com/forum/showthread.php?t=570444

PS: Please use code tags when you paste VBA code on the forum.
To add code tags, you should type in your post:

then paste your code, and lastly, type:

['/code]

WITHOUT the ' in front of the /

Thanks for the consideration.

 

[Mtaylorlc]

I am attempting to incorporate the change, but not having success thus far. I am not sure how to combine the two. The original code is both copying in the target documents and pasting in the summary document. Can you help me along a little further?

 

[wigi]

Then post the code you now have, but within

 tags as explained earlier.

 

[Mtaylorlc]

Sorry...

Private Sub cmdUpdate_Click()
Dim FS, i
Dim PlaceRow As Long
Dim OpenedName As String
Dim DoNotReopenActiveWB_Name As String
Dim DataBook As String

Sheet1.Range("A2:AF1000").ClearContents
Sheet1.Range("BA1:BA1000").ClearContents
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
DoNotReopenActiveWB_Name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
DataBook = ActiveWorkbook.Name
PlaceRow = 1
Debug.Print DoNotReopenActiveWB_Name
Set FS = Application.FileSearch
With FS
    .LookIn = ActiveWorkbook.Path
    .Filename = "*.xls"
    If .Execute Then
        For i = 1 To .FoundFiles.Count
            If .FoundFiles(i) <> DoNotReopenActiveWB_Name Then
                PlaceRow = PlaceRow + 1
                Workbooks.Open .FoundFiles(i)
                OpenedName = ActiveWorkbook.Name
                Workbooks(DataBook).Sheets("Table1") _
                    .Range("A" & PlaceRow & ":AF" & PlaceRow).Value = _
                Workbooks(OpenedName).Sheets("Sheet1") _
                    .Range("A114:AF114").Value
                Workbooks(DataBook).Sheets("Table1") _
                    .Range("BA" & PlaceRow).Value = .FoundFiles(i)
                Workbooks(OpenedName).Close savechanges:=False
            End If
        Next i
    End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[wigi]

That's the code with FileSearch, I asked for the one you are working on. The code with Dir().

Thank you for using code tags.

 

[Mtaylorlc]

Sorry again. misunderstood the request. I really have no idea how to merge the two... not a programmer...

Thank you,

Private Sub cmdUpdate_Click()
Dim FS, i
Dim PlaceRow As Long
Dim OpenedName As String
Dim DoNotReopenActiveWB_Name As String
Dim DataBook As String
Dim FolderName As String

FolderName = "C:\Documents and Settings\tmark\Desktop\Crowder Test Files"
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
Fname = Dir(FolderName & "*.xls")

Sheet1.Range("A2:AF1000").ClearContents
Sheet1.Range("BA1:BA1000").ClearContents
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
DoNotReopenActiveWB_Name = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
DataBook = ActiveWorkbook.Name
PlaceRow = 1
Debug.Print DoNotReopenActiveWB_Name
    Do While Len(Fname)
        With Workbooks.Open(FolderName & Fname)
            .LookIn = ActiveWorkbook.Path
            .Filename = "*.XLS"
    If .Execute Then
        For i = 1 To .FoundFiles.Count
            If .FoundFiles(i) <> DoNotReopenActiveWB_Name Then
                PlaceRow = PlaceRow + 1
                Workbooks.Open .FoundFiles(i)
                OpenedName = ActiveWorkbook.Name
                Workbooks(DataBook).Sheets("Table1") _
                    .Range("A" & PlaceRow & ":AF" & PlaceRow).Value = _
                Workbooks(OpenedName).Sheets("Sheet1") _
                    .Range("A114:AF114").Value
                Workbooks(DataBook).Sheets("Table1") _
                    .Range("BA" & PlaceRow).Value = .FoundFiles(i)
                Workbooks(OpenedName).Close savechanges:=False
            End If
        Next i
    End If
        End With
        ' go to the next file in the folder
        Fname = Dir
    Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub