V2003 Macro not working in V2007

[JMay-Rke]

This Code Worked PERFECT in V2003 - I'm having a time getting the equivalent
to work for me in V2007. Can someone assist me?
TIA,


Sub ListFiles()
Dim s As String
Dim sfolder As String
sfolder = Range("D1").Value
s = Range("B3").Value
Range("B4:B65536").ClearContents
s2 = "*" & s & "*.*"
With Application.FileSearch
.NewSearch
.LookIn = sfolder
.SearchSubFolders = True
.Filename = s2
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" file(s) found."
For i = 1 To .FoundFiles.Count
ActiveSheet.Cells(i + 3, 2).Value = _
Mid(.FoundFiles(i), 64, 256)
Next i
Else
MsgBox "There were no files found."
End If
End With
End Sub

 

[Dave Peterson]

The flakey .filesearch was removed in xl2007.

Ron de Bruin shows a couple of alternatives:
http://www.rondebruin.nl/copy3.htm
and
http://www.rondebruin.nl/fso.htm

 

[JMay-Rke]

WOW, this is a bit "over-the-top" confusing/new to me. I've been googling
the last 24 hrs - havibg seen and previoulsy studied Ron's Code. Still lost;
Being New to 2007 adds to my dilemma.

 

[Dave Peterson]

Try downloading one of the workbooks that Ron provides. Maybe you can step
through the code to understand it.

 

[JMay-Rke]

Dave;
I'm afraid I did - I ran it - got a disaster from it. Gonna have to put
this on the shelf until I have several days to "understand". Thanks,
Jim

 

[JMay-Rke]

Didn't take quiet a few days, but my new code I have as follows: It is working
intermittanly, that is the results are both **right* and **wrong**. Do you
see anything drastically wrong?
Thanks,
Jim


Sub ListFiles()
Dim sFol As String
Dim fso As Object, fl As Object
Dim fld As Object
Dim wb As Workbook
Dim Fcount As Long
sFol = ActiveSheet.Range("D1").Value
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(sFol)
s = Range("B3").Value
Range(Cells(4, 2), Cells(Rows.Count, 2)).ClearContents
s2 = "*" & s & "*.*"
Fcount = 0
I = 0
For Each fl In fld.Files
If fl.Name Like s2 Then
Fcount = Fcount + 1
End If
' End If
Next
MsgBox "There were " & Fcount & " file(s) found."
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
For Each fl In fld.Files
If fl.Name Like s2 Then
I = I + 1
Set wb = Workbooks.Open(fl.Path)
ThisWorkbook.ActiveSheet.Cells(I + 3, 2).Value = Mid(fl, 38, 256)
wb.Close False
End If
' End If
Next
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
' MsgBox "How does it look?"
End Sub

Dave;
I'm afraid I did - I ran it - got a disaster from it. Gonna have to put
this on the shelf until I have several days to "understand". Thanks,
Jim

 

[Dave Peterson]

I would use more of Ron's code. The top two procedures came directly from Ron's
sample workbook (with no changes at all!).
http://www.rondebruin.nl/fso.htm

They were in the Basic_Code_Module.

The third procedure just retrieved the values from the activesheet. I wasn't
sure what you were doing in your code, so this is mostly just msgboxes:


Option Explicit
Private myFiles() As String
Private Fnum As Long
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
ExtStr As String, myReturnedFiles As Variant) As Long

Dim Fsbj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'Create FileSystemObject object
Set Fsbj = CreateObject("Scripting.FileSystemObject")

Erase myFiles()
Fnum = 0

'Test if the folder exist and set RootFolder
If Fsbj.FolderExists(MyPath) = False Then
Exit Function
End If
Set RootFolder = Fsbj.GetFolder(MyPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(ExtStr) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = MyPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
End If

myReturnedFiles = myFiles
Get_File_Names = Fnum
End Function
Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
'Origenal SubFolder code from Chip Pearson
'http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by Ron de Bruin, 27-March-2008
Dim SubFolder As Object
Dim fileInSubfolder As Object

For Each SubFolder In OfFolder.Subfolders
ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt

For Each fileInSubfolder In SubFolder.Files
If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
End If
Next fileInSubfolder

Next SubFolder
End Sub


Sub DoTheWork()

Dim sFol As String
Dim sPattern As String
Dim TotFiles As Long
Dim myFiles As Variant
Dim fCtr As Long
Dim wkbk As Workbook

With ActiveSheet
sFol = .Range("D1").Value
sPattern = "*" & .Range("B3").Value & "*.xls"
End With

TotFiles = Get_File_Names(MyPath:=sFol, _
Subfolders:=True, _
ExtStr:=sPattern, _
myReturnedFiles:=myFiles)

If TotFiles > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Set wkbk = Nothing
On Error Resume Next
Set wkbk = Workbooks.Open(Filename:=myFiles(fCtr), ReadOnly:=True)
On Error GoTo 0
If wkbk Is Nothing Then
MsgBox myFiles(fCtr) & " wasn't opened"
Else
MsgBox fCtr & ". " & myFiles(fCtr)
wkbk.Close savechanges:=False
End If
Next fCtr
End If

End Sub

It kind of looked like you wanted to extract a partial name from the long file
name. If that's the case, remember that you can use instrrev() to find the
position of the last backslash.