Application.FileSearch in Excel 2007

Question

There is an issue which I am facing after I installed Office 2007.  I had written a small VBA which would search for a file and if found will rename the file.

I used Application.FileSearch then.  Now I am tying to do it again but unfortunately there is an error prompted stating that 'the object does not exist'

Set fSearch = Application.FileSearch

defPath = "H:\SourceSafe_1_Feb-28_Feb_2006\SecondSet"

Set rg = Range("MyFiles")
fSearch.LookIn = defPath

I have been frantically looking for changes in the VBA object model especially for Excel but cant seem to find them.

Answer 1

Hi,

I only have 2003 so this is just advice rather than an absolute answer. In the VBA Editor use the Object Browser and do a search (or browse) for the Application object. See if the FileSearch object is there.

If that doesn't help can you find a feature on the GUI to do the File Search. If you can record a macro and that will give you an idea of what legacy code to use.

I hope that helps.

Answer 2

I am having this same problem as well doing a very similar thing but in Excell. The code is as follows

    Set fs = Application.FileSearch
   
    With fs
        'retrieve all .doc files in DB directory
       
        .lookin = [Internal Functions].dirName
        .fileName = "*.doc"
        .Execute
        fC = .foundfiles.Count
        If fC = 0 Then Exit Sub

etc. etc. Its easy to see what its doing.

If anyone has a workaround for this or knows whether they replaced this function with a different name please post it! I have looked for hours and been unable to figure out a reciprocal command, nor why they would take it out of the language. Thanks so much!

 

John

Answer 3

Hi

I went back to using VBScript to get the job done

here is a snippet

Function ReportFileStatus(filespec)
   Dim fso, msg
   Set fso = CreateObject("Scripting.FileSystemObject")
   If (fso.FileExists(filespec)) Then
      msg = filespec & " exists."
   Else
      msg = filespec & " doesn't exist."
   End If
   ReportFileStatus = msg
End Function

this should do the job for you... ofcourse with a bit of modification. 
Make sure that you save the file in XLS format rather than the new XLSX format.

Glax

Answer 4

Thought I'd just put a quick reply to this as I was having trouble with this file searching process.  I used it in Access and then tried to use it when writing an Outlook macro, with no joy.  I think it is specific to Access, because I managed to change my code as follows and it now works.  Know this post is old, but if anyone has the same problem as us, could save hours of frustration. (You need to add the 'Microsoft Access 9.0 Object Library' to your references).

Sub processFiles()

Dim app02 As New Access.Application
Dim filename
Dim NumFiles
NumFiles = 0

line1:
With Access.Application.FileSearch
    .NewSearch
    .LookIn = "C:\Temp\Dataprep\"
    .SearchSubFolders = False
    .MatchTextExactly = True
    .filename = "*.*"
    .Execute

End With

If FileSearch.FoundFiles.Count > 0 Then
filename = FileSearch.FoundFiles.Item(1)

'Put your code that processes files here

Name filename As Left(filename, 17) & "processed\" & Mid(filename, 18, 60)
NumFiles = NumFiles + 1
GoTo line1
Else

End If
MsgBox NumFiles & " File(s) Processed!", vbOKOnly, "Finished!"
End Sub

All this code does is loop through the dataprep folder and place all the files it finds in a 'processed' sub folder.

This is placed in an excel module and seems to do the trick.  I know the code's probably badly written but hope it will be of use to someone.

 

Answer 5

Have a quick look at my response to the original question. Hope that helps mate.

Answer 6

Thanks! Brilliant!

DieZeL wrote:

Hi I went back to using VBScript to get the job done here is a snippet Function ReportFileStatus(filespec) Dim fso, msg Set fso = CreateObject("Scripting.FileSystemObject") If (fso.FileExists(filespec)) Then msg = filespec & " exists." Else msg = filespec & " doesn't exist." End If ReportFileStatus = msg End Function this should do the job for you... ofcourse with a bit of modification. Make sure that you save the file in XLS format rather than the new XLSX format. Glax

Answer 7

[quote user="DieZeL"]

Function ReportFileStatus(filespec)
   Dim fso, msg
   Set fso = CreateObject("Scripting.FileSystemObject")
   If (fso.FileExists(filespec)) Then
      msg = filespec & " exists."
   Else
      msg = filespec & " doesn't exist."
   End If
   ReportFileStatus = msg
End Function

Glax

Thats great!

But your function works only to find whether specific file exist or doesn't exist. Is there a way to find whether any files exist in the particular folder. If yes loop through all existing files.

I need to find all existing files and run some other code. Can u plz help to find all those files...
Thankyou.

Answer 8

sorry, Dear Danny,

".FileSearch."

it's no more time standard in 2007, SEVEN!

 

 

Answer 9

please look this niceFine link; it's the most I like in MSDN Scripting Runtime Library

FileSystemObject Sample Code

it's a great sample, a little bit too much ragged and cleved logic with procedures, but: all you need!

or use "CreateObject("Scripting.FileSystemObject")" as searchWord in MicrosoftMSDN

Answer 10

Application.FileSearch has been deprecated from Excel 2007.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Tutorials and Custom Solutions
http://PeltierTech.com
_______

Answer 11

But if you look in help you can see in searching SearchScope this:

Sub DisplayAvailableScopes()

    'Declare a variable that references a
    'SearchScope object.
    Dim ss As SearchScope

    'Use a With...End With block to reference the
    'FileSearch object.
    With Application.FileSearch

        'Loop through the SearchScopes collection.
        For Each ss In .SearchScopes
            Select Case ss.Type
                Case msoSearchInMyComputer
                    MsgBox "My Computer is an available search scope."
                Case msoSearchInMyNetworkPlaces
                    MsgBox "My Network Places is an available search scope."
                Case msoSearchInOutlook
                    MsgBox "Outlook is an available search scope."
                Case msoSearchInCustom
                    MsgBox "A custom search scope is available."
                Case Else
                    MsgBox "Can't determine search scope."
            End Select
        Next ss
    End With
End Sub

Filesearch exist or not in Access 2007, what do you think ?????

Answer 12

I don't know about Access. I do know .FileSearch is gone from Excel 2007. I also know that there is little practical information available yet on the changes to VBA or the Office 2007 Object Models.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Tutorials and Custom Solutions
http://PeltierTech.com
_______

Answer 13

9 months later, is there any practical information available now?

Answer 14

There has been little in the way of KB articles. Have you looked at the online help? That's what I was trying to use in January to explore the object model, but it was not yet mature enough, and using the object browser alone was also not very useful.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Tutorials and Custom Solutions
http://PeltierTech.com
_______

Answer 15

Jon Peltier wrote:

There has been little in the way of KB articles. Have you looked at the online help? That's what I was trying to use in January to explore the object model, but it was not yet mature enough, and using the object browser alone was also not very useful. - Jon ------- Jon Peltier, Microsoft Excel MVP Tutorials and Custom Solutions http://PeltierTech.com _______

 

I have also had problems. is there not a replacement. i use excell for quoting.

i do a search to count the number of files to auto increment the number in the file name.

then save the file. This worked fine under 2003.......but that was then.

any one with an idea for a workaround would be appreciated.

thanx

 

Michael

 

CODE

 

Private Sub Save_Quote_Click()
Dim Fname, Dname, nf, hr, response, mystring
Dim objShell  As Shell
Dim objFolder As Folder
  

        Range("C10").Select
    
    Dname = GetFolder(CSIDL_PERSONAL) + "\Quotes\"
    Fname = Range("d5")
    ActiveWorkbook.BuiltinDocumentProperties.Item("Comments").Value = Range("System_Comments")
   
With Application.FileSearch
    .NewSearch
    .LookIn = Dname
    .Filename = Left(Fname, Len(Fname) - 1) + "*.xls"
    .FileType = msoFileTypeExcelWorkbooks

    If .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending) > 0 Then
       ' MsgBox "There were " & .FoundFiles.Count & _
        " file(s) found."
       
        nf = .FoundFiles.Count
        Fname = Fname & "_" & nf
       

        If Range("New_File") = 0 Then MsgBox "Saving As " & ActiveWorkbook.Name: _
        ActiveWorkbook.Save Else Range("New_File") = 0
        response = MsgBox("Saving As " & Dname & Fname, vbYesNo, "Hare And Now Consulting Inc.")
            If response = vbYes Then    ' User chose Yes.
                mystring = "Yes"
            Else    ' User chose No.
                End
            End If

        ActiveWorkbook.SaveAs _
        Filename:=Dname & Fname, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
       
    Else
        Range("New_File") = 0
         response = MsgBox("Saving As " & Dname & Fname, vbYesNo, "Hare And Now Consulting Inc.")
            If response = vbYes Then    ' User chose Yes.
                mystring = "Yes"    ' Perform some action.
            Else    ' User chose No.
                End  ' Perform some action.
            End If
        ActiveWorkbook.SaveAs Filename:=Dname & Fname, _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
       
    End If
End With
 Range("C10").Select
 ActiveWorkbook.Saved = True
End Sub

 

 

Answer 16

Anyone have any news about this "feature"????  I just found out about it trying to run one of my macros after installing Office 2007.  Thanks in advance!!!!

 

Answer 17

No news. FileSearch is gone and is going to stay that way.

 

Earlier in this thread, someone posted a FSO solution, and you can use Dir just as effectively. Look up File System Object or VB File System for guidance.

 

You might also take a shot at Googling "FileSearch replacement", because some time back I saw a class module someone had posted that essentially mimics the FileSearch functionality.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Tutorials and Custom Solutions
Peltier Technical Services, Inc. - http://PeltierTech.com
_______

 

Answer 18

Hi!

I've prepare an example to you (with FSO). This is a recursive function, which returns last found file. It quite simple and you can use this code:

 

'Procedure to launch
Sub FileSearch()

 

Dim sStartPath As String
Dim sWhat As String
Dim result As String

sStartPath = "C:\Archive\" 'Where?
sWhat = "test.log" 'What?
result = DigIn(sStartPath, sWhat) 'First step
MsgBox result

 

End Sub

 

Function DigIn(sPath As String, sWhat As String) As String

Dim fs As New FileSystemObject
Dim dDirs As Folder
Dim dDir As Folder
Dim fFile As File

Set dDirs = fs.GetFolder(sPath)

For Each dDir In dDirs.SubFolders
    DigIn = DigIn(dDir.Path, sWhat) ' Here is the recursion
Next
For Each fFile In dDirs.Files
    If fFile.ShortName = sWhat Then ' File checking
        DigIn = fFile.Path
        Exit Function ' You can remove that if you don't want to wait for all files
    End If
Next

 

End Function

 

Answer 19

Hi,

I've another, easy to use, solution for the FileSearch replacement, when no recursion is needed.
I'm using Dir and a Collection to process all the files of one type in a directory.
It works with Winword, Access an Excel and you can add, rename or delete files in the directory.

 

Sub File_Search()

 

    Dim Coll_Docs As New Collection
    Dim Search_path, Search_Filter, Search_Fullname as String
    Dim DocName As String

    Dim i as Long

 

    Search_Path = "C:\Testpath"   ' where ?
    Search_Filter = "*.doc"            ' what ?
    Set Coll_Docs = Nothing

 

    DocName = Dir(Search_Path & "\" & Search_Filter)

    Do Until DocName = ""            ' build the collection
        Coll_Docs.Add Item:=DocName
        DocName = Dir
    Loop

 

    MsgBox "There were " & Coll_Docs.Count & " file(s) found."
   
    For i = Coll_Docs.Count To 1 Step -1              '
        Search_Fullname = Search_Path & "\" & Coll_Docs(i)

 

    (your code here)

 

    Next

 

End Sub
    
    
   
Jean-Paul

Answer 20

 

Recursion is still required if you went to read files in any subdirectories.

- Jon
-------
Jon Peltier, Microsoft Excel MVP
Tutorials and Custom Solutions
Peltier Technical Services, Inc. - http://PeltierTech.com
_______

Answer 21

Hello,

 

I've found a simple variant (which can avoid "application.filesearch") in the Help file from Access 2007.

I would like to share it with anyone might be interested.

 

Sub ShowFolderList (folderspec)

Dim fs, f, f1, fc, s

Set fs = CreateObject ("Scripting.FileSystemObject")

Set f = fs.GetFolder(folderspec)

Set fc = f.Files

For Each f1 in fc

s = s & f1.name

s = s & vbCrLf

Next

MsgBox s

End Sub

 

'Just replace "folderspec" with the correct path (like Set f = fs.GetFolder ("C:\My Documents")) and it should run.

 

Best regards,

Bogdan

Answer 22

I can't believe what I am reading here.  I just upgraded my machine to Excel 2007 and ran into the same problem discussed in this thread.  Why on earth would Microsoft remove something that people have written into their tools?  I thought one of the guarantees about using Microsoft products for development was that forward compatibility was guaranteed.  Isn't that why we go to so much trouble to write code the way Microsoft wants us to, so we know the code will still work in future versions?  When I think of all the times in the past we got our hands slapped by Microsoft for circumventing their API and breaking in future versions, I'm beginning to wonder, what's the point?  Even if we do follow their prescribed advice, we are still hosed.

 

We have created several tools at my company that depend on FileSearch; and we have distributed these tools to thousands of people within the company.  Providing us with different ways to accomplish the same task that FileSearch performed for us doesn't help us; we still have to distribute the re-written tool to thousands of people and we don't know who these thousands of people are.  And, because we don't know who these thousands of people are, we are either going to get hit with thousands of Support calls or people will stop using our tools.

 

The other thing that really concerns me is why the MSDN 2007 help topics still reference FileSearch (as someone else pointed out many months ago in this thread).  Why hasn't someone at Microsoft removed those references?  That caused us much more difficulty because by seeing these references, it never occured to us that FileSearch had been removed.  So, we have spent countless hours trying to debug our code.  Geez, why don't I get a topic saying "FileSearch has been removed" when I search help for FileSearch?

 

I'm sorry, but this just doesn't make sense to me.  How could Microsoft do this to their customers?  This will certainly delay our upgrades.

Answer 23

Mezhick wrote:

Hi! I've prepare an example to you (with FSO). This is a recursive function, which returns last found file. It quite simple and you can use this code:   'Procedure to launch Sub FileSearch()   Dim sStartPath As String Dim sWhat As String Dim result As String sStartPath = "C:\Archive\" 'Where? sWhat = "test.log" 'What? result = DigIn(sStartPath, sWhat) 'First step MsgBox result   End Sub   Function DigIn(sPath As String, sWhat As String) As String Dim fs As New FileSystemObject Dim dDirs As Folder Dim dDir As Folder Dim fFile As File Set dDirs = fs.GetFolder(sPath) For Each dDir In dDirs.SubFolders     DigIn = DigIn(dDir.Path, sWhat) ' Here is the recursion Next For Each fFile In dDirs.Files     If fFile.ShortName = sWhat Then ' File checking         DigIn = fFile.Path         Exit Function ' You can remove that if you don't want to wait for all files     End If Next   End Function

 

I got this to work with some modifications (currently testing in Excel 2003, do not yet have 2007).

The compiler didn't like the definition "Dim fs As New FileSystemObject" so I looked up FileSystemObject and found this to be useful http://msdn2.microsoft.com/en-us/library/2z9ffy99.aspx... as it says, you have to have the Scripting library installed (scrrun.dll, or Tools>References>Microsoft Scripting Runtime).  So I changed the definition of the FSO, as highlighted in the code below.

 

Secondly, I had to change the "fFile.ShortName" if-then statement to "fFile.Name" because "ShortName" was looking for an abbreviated filename that uses the tilde "~"

 

But thanks for the code... I hope it works when my company forces us to Office 2007  =P

 

Code Snippet

Function DigIn(sPath As String, sWhat As String) As String

Dim fso
Dim dDirs As folder
Dim dDir As folder
Dim fFile As File

 

Set fso = CreateObject("Scripting.FileSystemObject")

Set dDirs = fso.GetFolder(sPath)

'For Each dDir In dDirs.SubFolders
'    DigIn = DigIn(dDir.Path, sWhat) ' Here is the recursion
'Next
For Each fFile In dDirs.Files
    If fFile.Name = sWhat Then ' File checking
        DigIn = fFile.Path
        Exit Function ' You can remove that if you don't want to wait for all files
    End If
Next

 

End Function

 

 

Answer 24

This is some code I was able to make work in Excel 2007.  It replaces Application.Filesearch, uses wildcards, and looks in subfolders.  It's not the most sophisticated code, but it gets the job done.  I thought I'd post it since I've been having such a hard time finding examples with all three elements in them.

 

Dim lst As New Collection

 

Sub FileSearch()
Dim sStartPath  As String
Dim sWhat       As String
Dim result      As String
Dim t           As Integer
Dim tmp         As String

sStartPath = "C:\archive\" 'Where?
sWhat = "*.pdf" 'What?

If lst.Count > 0 Then
    Do
        lst.Remove lst.Count 'clears list if data already exists
    Loop Until lst.Count = 0
End If
ThisWorkbook.Sheets(1).Columns(1).ClearContents

result = DigIn2(sStartPath, sWhat) 'First step
For t = lst.Count To 1 Step -1
    ThisWorkbook.Sheets(1).Cells(t, 1) = lst(t) 'puts data in 1st sheet, 1st column
    lst.Remove t
Next t
Columns("A:A").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub

 

Function DigIn2(sPath As String, sWhat As String)
   
    Dim fs
    Dim dDirs
    Dim dDir
    Dim fFile
    Dim c       As Variant
    Dim tmp     As String
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dDirs = fs.GetFolder(sPath)
   
    For Each dDir In dDirs.SubFolders
        tmp = DigIn2(dDir.Path, sWhat)
    Next
    tmp = Dir(dDirs.Path & "\" & sWhat)
    If tmp <> "" Then
        Do
            lst.Add dDirs.Path & "\" & tmp
            tmp = Dir
        Loop Until tmp = ""
        Exit Function
    End If
End Function

 

Answer 25

i'm pretty pissed microsoft put the Application.FileSearch out....

now i don't know what to do..

 

sombody know how to make this script work in office 2007 ?

 

 

Dim i As Long
    With Application.FileSearch
        .NewSearch
        .LookIn = NewTemplatePath
        .SearchSubFolders = False
        .FileType = msoFileTypeAllFiles
        If .Execute > 1 Then
            If .FoundFiles.Count = 0 Then
                MsgBox "Error - Er zijn geen .dot bestanden gevonden.", vbCritical
                Exit Sub
            End If
            For i = 1 To .FoundFiles.Count
                If Right(.FoundFiles(i), 3) = "dot" Then
                    Call Me.cboTemplates.AddItem(FileNameOnly(.FoundFiles(i)))
                End If
            Next i
        End If
    End With

Answer 26

Try something like this.

 

'Dim i As Long

Dim tmp
'    With Application.FileSearch
'        .NewSearch
'        .LookIn = NewTemplatePath

 

tmp = Dir(NewTemplatePath & "*.*")

'        .SearchSubFolders = False
'        .FileType = msoFileTypeAllFiles
'        If .Execute > 1 Then

'            If .FoundFiles.Count = 0 Then

 

            If tmp = "" then
                MsgBox "Error - Er zijn geen .dot bestanden gevonden.", vbCritical
                Exit Sub
            End If

'            For i = 1 To .FoundFiles.Count

 

Do
'                If Right(.FoundFiles(i), 3) = "dot" Then

 

                If Right(tmp, 3) = "dot" then
                    Call Me.cboTemplates.AddItem(FileNameOnly(tmp))
                End If

'            Next i

 

Loop Until tmp = ""
'        End If
'    End With

Answer 27

memig wrote:

Try something like this.   'Dim i As Long Dim tmp '    With Application.FileSearch '        .NewSearch '        .LookIn = NewTemplatePath   tmp = Dir(NewTemplatePath & "*.*") '        .SearchSubFolders = False '        .FileType = msoFileTypeAllFiles '        If .Execute > 1 Then '            If .FoundFiles.Count = 0 Then               If tmp = "" then                 MsgBox "Error - Er zijn geen .dot bestanden gevonden.", vbCritical                 Exit Sub             End If '            For i = 1 To .FoundFiles.Count   Do '                If Right(.FoundFiles(i), 3) = "dot" Then                   If Right(tmp, 3) = "dot" then                     Call Me.cboTemplates.AddItem(FileNameOnly(tmp))                 End If '            Next i   Loop Until tmp = "" '        End If '    End With

 

well it seems to work..but when i execute the script it stays in a continuous loop and nothing will respond..

 

any suggestions?

Answer 28

I appologize!  Before Loop Until tmp = "" there should be a line that states tmp = Dir.  Try that and see if it works.

Answer 29

You folks have posted several Excel 2007 compatible (I think) code snippets that collect file names and dive into sub-directories.

 

I'm not following all of this very well....

 

I have a need to process all files found within a specific directory that I supply to the sub, here's my code below (minus the processing part).

 

Any specific suggestions for alternatives in this code for  "FileSearch" ???

 

    
    
With Application.FileSearch
        .NewSearch
        .LookIn = FilePath
        .Filename = "*.txt"
        .SearchSubFolders = False
        .Execute
        
        For i = 1 To .FoundFiles.Count
             
            InFile = .FoundFiles(i)
                         
            Workbooks.Open Filename:=.FoundFiles(i)

' do things with this file

 

Next i

 

End With

 

Answer 30

Found the following which provides a workaround and sample code...

 

Microsoft Help and Support

Answer 31

here is a modified version of jpschmit

 

replacement for application.filesearch.foundfiles Excel 2007

 

Sub test()
Dim Coll_Docs As New Collection
Set Coll_Docs = Nothing
File_Search "filepath", "filename", Coll_Docs

  MsgBox "There were " & Coll_Docs.Count & " file(s) found."
   
    For i = Coll_Docs.Count To 1 Step -1              '
      
        MsgBox Coll_Docs(i)
 
    Next

End Sub

Sub File_Search(rootpath As String, filename As String, ByVal Coll_Docs As Collection)
    Dim DocName As String
    Dim i As Long
    Dim Search_Filter As String
    Search_Filter = "*.*"
   
   DocName = Dir(rootpath & "\" & Search_Filter)
  
    Do Until DocName = ""
     If DocName = filename Then
            Coll_Docs.Add Item:=rootpath + "\" + DocName   //this shows the full path for the doc
     End If
     DocName = Dir
    Loop

   
    Dim fs, f, s
     Set fs = CreateObject("Scripting.FileSystemObject")
     Set f = fs.GetFolder(rootpath)

    Dim subfolder
    Dim rootpathx As String
    Set subfolder = f.subfolders
    For Each f1 In subfolder
        rootpathx = rootpath & "\" & f1.Name
            File_Search rootpathx, filename, ByVal Coll_Docs
          
        Next
End Sub

 

Answer 32

I had the same problem with an Application which uses Excel as a front-end when moving from Excel 2003 to 2007. Here is the rewrite of my code which I solved it with.

 

Public Function SearchFiles(ByVal vsSrcDir As String, ByVal vsSrchFile As String, _
                        rasFileList() As String) As Integer
' This function searches for a file or files (if wildcards are used)
' in a source directory. The filename and source directory
' are passed as parameters. A list of files found are returned in an array,
' with a flag indicating whether files were found.
' Returns:
' 1) 0 if no files
' 2) 1 if files found
' 3) 2 if error occurred

' Declare local variables
Dim oFileS As Object
Dim oFldr As Object
Dim oFileColl As Object
Dim oFile As Object

On Error GoTo errorhandler5
          
    Set oFileS = CreateObject("Scripting.FileSystemObject")
    Set oFldr = oFileS.GetFolder(vsSrcDir)
    Set oFileColl = oFldr.Files
    SearchFiles = 0
    nI = -1
    For Each oFile In oFileColl
        If UCase(oFile.Name) Like UCase(vsSrchFile) Then
                nI = nI + 1
                ReDim Preserve rasFileList(nI)
                rasFileList(nI) = vsSrcDir + UCase(oFile.Name)
                SearchFiles = 1
        End If
    Next
          
    Set oFileS = Nothing
    Set oFldr = Nothing
    Set oFileColl = Nothing
    Set oFile = Nothing
          
Exit Function

errorhandler5:
    SearchFiles = 2
    MsgBox "Function FileAccess.SearchFiles: " & Err.Number & vbTab & Err.Description
End Function

 

Regards.

 

Jeggels

 

Answer 33

I know nothing about macros. Are there any replys that would work with this macro? All replys appreciated.

 

 

 

 

Public Const DrawSheet = "ALLSTATESDRAWS"
Public Const AdminSheet = "Admin"
Public Const SourceDirectory = "c4"

Dim i, f, xPath, ThisFile, lr, xDate, xNum, LastCol, LastRow, findRow, FindCol, rng, xFile
Sub SearchFiles()

Sheets(DrawSheet).Select
answer = MsgBox("Clear existing data from ALLSTATESDRAWS Page?", vbYesNo, "Clear exsiting database?")
If answer = vbYes Then Cells.Clear

LastRow = Range("a65536").End(xlUp).Row
If LastRow < 5 Then LastRow = 5
LastCol = Range("iv1").End(xlToLeft).Column
If LastCol < 2 Then LastCol = 2

'file path
If Right(Sheets(AdminSheet).Range(SourceDirectory), 1) <> "\" Then Sheets(AdminSheet).Range(SourceDirectory) = Sheets(AdminSheet).Range(SourceDirectory) & "\"
xPath = Sheets(AdminSheet).Range(SourceDirectory)

'find all .xls files
With Application.FileSearch
    .NewSearch
    .LookIn = xPath
    .Filename = "*.xls"
    .FileType = msoFileTypeAllFiles
    .Execute
End With
With Application.FileSearch
   
    For i = 1 To .FoundFiles.Count
        f = .FoundFiles(i)
        If Right(f, 3) = "xls" Then
            If CBool(Len(Dir(f))) = True Then GetData
            End If
    Next i
End With

Beep

'sort database
Sheets(DrawSheet).Select
LastRow = Range("a65536").End(xlUp).Row
LastCol = Range("iv1").End(xlToLeft).Column
rng = "a6:" & Cells(LastRow, LastCol).Address
Worksheets(DrawSheet).Range(rng).Sort _
        Key1:=Worksheets(DrawSheet).Range("A1")
        'Key2:=Worksheets("Sheet1").Range("B1")

Beep

End Sub

Sub GetData()

ThisFile = ActiveWorkbook.Name

Workbooks.Open Filename:=f
'find filename
xFile = Replace(ActiveWorkbook.Name, ".xls", "")

'find last row
lr = Range("a65536").End(xlUp).Row
For r = 2 To lr
    xDate = Range("a" & r)
   
    If Val(xDate) > 0 Then
   
    xNum = Range("b" & r) & Range("c" & r) & Range("d" & r)
   
    'find matching row
    rng = "a1:a" & LastRow
    findRow = 0
    findRow = Application.WorksheetFunction.CountIf(Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), xDate)
    If findRow > 0 Then
        xDate = DateValue(xDate) * 1
      
        findRow = Application.WorksheetFunction.Match(xDate, Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), 0)
        Else
        LastRow = LastRow + 1
        findRow = LastRow
        Workbooks(ThisFile).Sheets(DrawSheet).Cells(findRow, 1) = xDate
        End If
   
    'find matching column
    rng = "a1:" & Cells(1, LastCol).Address
    FindCol = 0
    FindCol = Application.WorksheetFunction.CountIf(Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), xFile)
    If FindCol > 0 Then
       
        FindCol = Application.WorksheetFunction.Match(xFile, Workbooks(ThisFile).Sheets(DrawSheet).Range(rng), 0)
        Else
        LastCol = LastCol + 1
        FindCol = LastCol
        Workbooks(ThisFile).Sheets(DrawSheet).Cells(1, FindCol) = xFile
        End If
       
    'dump data to cell at row/column co-ordinates
    Workbooks(ThisFile).Sheets(DrawSheet).Cells(findRow, FindCol) = xNum
   
    End If
   
    Next r
    
ActiveWorkbook.Close

 

End Sub

 

 

Answer 34

ok, this thread has been going for a while and no one has visited for some time. When I noticed that FileSearch was missing after I updated to Office 2007, I decided to recreate the class and save it as a file to import anytime I needed to use it. I tried to use as little code as possible, so if there is some property you would need to add then you may have to add it your self, but this will at least give you most of the funcitonality of the original Class without having to update your existing code too much. You have to just referenct the class and then it can still be used in a with block or however you are accustomed. Here are the two class files that I have, the first I named FileSearch (go figure):

Dim pLookIn As String
Dim pSearchSubFolders As Boolean
Dim pFileName As String

Public FoundFiles As New Collection
       
Public Property Get LookIn() As String
    LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
    pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
    LookIn = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
    pSearchSubFolders = value
End Property
Public Property Get fileName() As String
    fileName = pFileName
End Property
Public Property Let fileName(value As String)
    pFileName = value
End Property
Public Function Execute() As Long
   
        Dim ex As Long
        Dim sLookIn As String
        Dim sDirName As String
        Dim sSubDir As String
        Dim sFileName As String
        Dim ff As FilesFound
   
            Set ff = New FilesFound
            sLookIn = LookIn
            sDirName = Dir(sLookIn, vbDirectory)
            sFileName = Dir(sLookIn & "\", vbNormal)
            Do Until Len(sFileName) = 0
                If sFileName Like fileName Then
                    ff.AddFile sLookIn, sFileName
                    FoundFiles.Add (ff.FoundFileFullName)
                End If
                sFileName = Dir
            Loop
            If SearchSubFolders Then
                Do Until Len(sDirName) = 0
                    If GetAttr(sLookIn & sDirName) = vbDirectory Then
                        sSubDir = sDirName
                        Do Until Len(sFileName) = 0
                            If GetAttr(sDirName) = vbNormal Then
                                sFileName = sDirName
                                ff.AddFile sDirName, sFileName
                                FoundFiles.Add (ff)
                            End If
                        Loop
                    End If
                    sDirName = Dir
                Loop
            End If
   
    Execute = FoundFiles.Count
   
End Function

The second I named FilesFound and the code is as follows:

Public FoundFileFullName As String

Public Function AddFile(path As String, fileName As String)
    FoundFileFullName = path & "\" & fileName
End Function


That should do it.

To use it in your code just create the two class modules and then use it as such:

    Dim sFile as String
    Dim fs As New FileSearh

    With fs
        .LookIn = sPath
        .SearchSubFolders = True
        .fileName = "*"
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                sFile = .FoundFiles(i)
                    ' your code here

            Next
        End If
    End With

so it works exactly the same. The only difference I know of is, if the file you're looking for may have any extension use "*"  instead of "*.*" as microsoft put out. I was lazy and just did a like comparison instead of breaking out the file extensions. All others should theoretically work fine i.e. "*.xls" or "*.txt"

That's it. Enjoy!!!!!!!!


James

Answer 35

Hi AT T IT,

I sympathise with you. Here a design suggestion that can protect your future development from tier party stupidity. I have done in the past a solution that works a follows;

On all the user computers, I have made a Addin that checks in a supporting file (read only) on the network the type of user. This verification uses the user name in the Excel application. After this verification is done, the user identify is assigned to a given group for which the addin automaticaly uninstall/install a set of addins specific to the user group. The other addins contain specific tools that the user might need for their work and are found in a read-only folder on the network.

When I needed to update the addins on all computers, I just had to make a new version of the addin in question and set the update to due date in the user account file to now for this addin.

You can push a script too... when the user session starts then the script install the new addin. If your users to not share the same network... send by email a installation .cab containing the required installation files.

JR

Answer 36

Mezhick,

Your recursion is nice, but you forgot to check your return for a variable before overwriting. I have highlighted my code below.

Skip

 

Function DigIn(sPath As String, sWhat As String) As String

Dim fs As New FileSystemObject
Dim dDirs As Folder
Dim dDir As Folder
Dim fFile As File

Set dDirs = fs.GetFolder(sPath)

For Each dDir In dDirs.SubFolders
    DigIn = DigIn(dDir.Path, sWhat) ' Here is the recursion
    ' This will allow the function to return a value once it finds the file - smcherniss
    If DigIn Is Not Empty Then 
        Exit Function
    End If
Next
For Each fFile In dDirs.Files
    If fFile.ShortName = sWhat Then ' File checking
        DigIn = fFile.Path
        Exit Function ' You can remove that if you don't want to wait for all files
    End If
Next

 

End Function

Answer 37

This is great.  Im doing an exact thing just with csv files.

Answer 38

I hope everyone can imagin how much damage that responsible has made, who made the descision to eliminate the
Application.FileSearch object from VBA, from Excel? At least we have a big problem now.

In short: It is a shame what ever the genius replacment for Application.FileSearch is, how ever genial it is this replacement.
I call it a very stupid descision to take it out.

When you seek in Google for Application.FileSerach then you can find more then 11'000 entries for Application.FileSearch. Maybe daily more. 

And I think there are more then 11'000 peoples now having one or the other problem in one or the other way.

Lets assume that every 10th engineer writes something Google can find, that would mean, that about 100'000 peopels having problems.

To assess the situation, a problem solfer and developers group has to assess the varying situations and find a solution for the cause. Then Work has to be performed, all over design and implementation up to deployment. Can you imagin how many hours will be spent for this to be fixed?

Given over all, I guess, there are more then 100'000 enginers spending 10 hours each, but I guess its about 50 to 100 hours to cure the problem where ever it exists, then we talk about 1 Million to 10 Milliom hours of work! OK? 

Then multiply this 10 Million work hours by the hourly rate of your company and you have the damage caused by the stupid descision to take Application.FileSearch away from Excel. It can sum up easy to 100 Million up to 1000 Million $ or €.

If every human knows how to use a hammer.OK, then is enforced by an organizuation to us a stone to hit the nails.
Can you imagin the damage caused world wide?

I wonder if someone, hopefully from Microsft can come up with a very good official explanation to tell us at least what has lead to the stupid descision to remove Application.FileSerach from Excel. Maybe we can learn something, maybe not. In any case we all have to fix all our Macros and who pays us to do that?

And if you look about how many used function has been taken out, then the damage is much higher.

Answer 39

stadelma I completely agree with what you are saying, this is unbelievable to me.  I work in a very small I.T. shop and have inherited a vb Excel program that we update every year for the next year's use (it is used for budgeting).  Last year in Excel 2003 I was able to figure out all the vb I needed, as I just needed to make tweaks, yet this year with this new 'missing' feature, I am stumped.  You see, I am not a techie programmer type, but yet I have a bit of an aptitude, and we don't have any programmers on staff in our tiny little i.t. shop, and with the current state of the economy we are not able to procure a programmer for this, and it is a small job for an experienced programmer anyway, at least with our one program.  So I think I have figured out that this is a way for Microsoft to generate more revenue, because when I went to contact their support, I was met with a web page describing the $99 one time question fee!  I guess I'll have to fork that over, well the ailing company I work for will...  This is the 'Bill Gates Tax'.

Answer 40

'!!!!!!!!!! Replacement solution including searching in subdirectories !!!!!!!!!!!!!!!!!


//------------------------------------------------------------------------------------------------

Sub FileSearchByHavrda_Example_of_procedure_calling()
'
' Example of FileSearchByHavrda procedure calling as replacement of missing FileSearch function in the newest MS Office VBA
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection    ' create a collection of filenames

' Filling a collection of filenames (search Excel files including subdirectories)
Call FileSearchByHavrda(ListOfFilenamesWithParh, "C:\Temp", "*.xls", True)

' Print list to immediate debug window and as a message window
For Each FileNameWithPath In ListOfFilenamesWithParh    ' cycle for list(collection) processing
        Debug.Print FileNameWithPath & Chr(13)
        MsgBox FileNameWithPath & Chr(13)
Next FileNameWithPath

' Print to immediate debug window and message if no file was found
If ListOfFilenamesWithParh.Count = 0 Then
    Debug.Print "No file was found !"
    MsgBox "No file was found !"
End If

End Sub

//------------------------------------------------------------------------------------------------

Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"

' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile  'add file name to list(collection)
DirFile = Dir ' next file
Loop

' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub

' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
    ' Add subdirectory to local list(collection) of subdirectories in path
    If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
    DirFile = Dir 'next file
Loop

' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
     Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next

End Sub

//------------------------------------------------------------------------------------------------

Answer 41

'!!!! Replacement solution including searching in subdirectories !!!


//------------------------------------------------------------------------------------------------

Sub FileSearchByHavrda_Example_of_procedure_calling()
'
' Example of FileSearchByHavrda procedure calling as replacement of missing FileSearch function in the newest MS Office VBA
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection    ' create a collection of filenames

' Filling a collection of filenames (search Excel files including subdirectories)
Call FileSearchByHavrda(ListOfFilenamesWithParh, "C:\Temp", "*.xls", True)

' Print list to immediate debug window and as a message window
For Each FileNameWithPath In ListOfFilenamesWithParh    ' cycle for list(collection) processing
        Debug.Print FileNameWithPath & Chr(13)
        MsgBox FileNameWithPath & Chr(13)
Next FileNameWithPath

' Print to immediate debug window and message if no file was found
If ListOfFilenamesWithParh.Count = 0 Then
    Debug.Print "No file was found !"
    MsgBox "No file was found !"
End If

End Sub

//------------------------------------------------------------------------------------------------

Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'

Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection

' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"

' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile  'add file name to list(collection)
DirFile = Dir ' next file
Loop

' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub

' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
    ' Add subdirectory to local list(collection) of subdirectories in path
    If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
    DirFile = Dir 'next file
Loop

' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
     Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next

End Sub

//------------------------------------------------------------------------------------------------

Answer 42

Let's not forget that Microsoft's main concern as a business is making "great money" (peddling software), not "great software", otherwise they'd be another Apple... 

Its o.k to depreciate things - that's progress.  But to leave everyone clueless as to what's going on and what the replacement is for the lost functionality is irresponsible and incompetent.

I still remember when lots of developers adopted VB 6.0 hook, line, and sinker - it became their very reason for existence - with the idea that things would only improve.  Then Microsoft trashed it all to throw together .Net so it would look like they weren't caught flat-footed by the internet revolution (they were - which is why so many other technologies forged internet development - with Microsoft conspicuously absent.)  Many developers felt betrayed.  Some pledged to NEVER leave 6.0 while many others jumped ship altogether to go to Java.

The moral of the story is - don't fall in love with any MS technologies - they have a habit of trashing them for something "completely different" (read that as "creating the need to buy again").

By the way, I noticed that MS was using the term "innovation" a lot in its 2007 product marketing materials.  I thought this was great and long over due until someone inside Redmond told me about the joke going around that "innovation" was the new p.c. term for "oops, we screwed that up!"

Now there's a news tidbit that makes sense! :)

By the way... I used the solution proposed in the previous post and, after slight modification for my particular needs, IT WORKED LIKE A CHARM!!!!!!  Nice going, PaHabr!

Answer 43

Thank you so much P. Havrda!  This worked perfectly with no modification required.

Answer 44

The default SearchSubFolders = False, put .SearchSubFolders = True and it will works fine:

            With Application.FileSearch
                .SearchSubFolders = True

Answer 45

Hi Everyone, you have been so helpful so let me ask if you have a solution to my particular VB Application.FileSearch issue... thanks for all replies! 

Sub GetAllPendingFiles()

    Sheets("Sales Board").Select
    Range("A2").Select

With Application.FileSearch
    .NewSearch
    .LookIn = "\\MAXIMUS\CorpSale\Pending Final"  '<== set the directory
    .SearchSubFolders = False
    .Filename = "*.xls"
    .MatchTextExactly = True
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
        MsgBox "There were " & .FoundFiles.Count & _
            " file(s) found."
        For i = 1 To .FoundFiles.Count
            Set wkbk = Workbooks.Open(Filename:=.FoundFiles(i), UpdateLinks:=0)
              wkbk.ActiveSheet.Copy _
              after:=ThisWorkbook.Sheets(1)
            wkbk.Close savechanges:=False
           
        Range("A2:CU2").Select
        Selection.Copy
        Sheets("Sales Board").Select
        ActiveCell.Select
        ActiveSheet.Paste Link:=True
        ActiveCell.Offset(1, 0).Range("A1").Select
                   
        Next i
    Else
        MsgBox "There were no files found."
    End If
End With
 
    Range("A2").Select
    MsgBox "Task completed - 1. Select All Data except Date   2.PRESS F5,THEN CLICK 'SPECIAL'   3.CLICK 'VISIBLE CELLS ONLY'    4.CLICK 'COPY'    5. 'PASTE SPECIAL' AS 'VALUES' INTO THIS FILE: \\WARHORSE\INETPUB\INTRANET\SALES\SALESBOARDWEB   5. SAVE 'SALESBOARDWEB' AND EXIT"
 
 
End Sub

 

 

Answer 46

ok, this thread has been going for a while and no one has visited for some time. When I noticed that FileSearch was missing after I updated to Office 2007, I decided to recreate the class and save it as a file to import anytime I needed to use it. I tried to use as little code as possible, so if there is some property you would need to add then you may have to add it your self, but this will at least give you most of the funcitonality of the original Class without having to update your existing code too much. You have to just referenct the class and then it can still be used in a with block or however you are accustomed. Here are the two class files that I have, the first I named FileSearch (go figure):

Dim pLookIn As String
Dim pSearchSubFolders As Boolean
Dim pFileName As String

Public FoundFiles As New Collection
       
Public Property Get LookIn() As String
    LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
    pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
    LookIn = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
    pSearchSubFolders = value
End Property
Public Property Get fileName() As String
    fileName = pFileName
End Property
Public Property Let fileName(value As String)
    pFileName = value
End Property
Public Function Execute() As Long
   
        Dim ex As Long
        Dim sLookIn As String
        Dim sDirName As String
        Dim sSubDir As String
        Dim sFileName As String
        Dim ff As FilesFound
   
            Set ff = New FilesFound
            sLookIn = LookIn
            sDirName = Dir(sLookIn, vbDirectory)
            sFileName = Dir(sLookIn & "\", vbNormal)
            Do Until Len(sFileName) = 0
                If sFileName Like fileName Then
                    ff.AddFile sLookIn, sFileName
                    FoundFiles.Add (ff.FoundFileFullName)
                End If
                sFileName = Dir
            Loop
            If SearchSubFolders Then
                Do Until Len(sDirName) = 0
                    If GetAttr(sLookIn & sDirName) = vbDirectory Then
                        sSubDir = sDirName
                        Do Until Len(sFileName) = 0
                            If GetAttr(sDirName) = vbNormal Then
                                sFileName = sDirName
                                ff.AddFile sDirName, sFileName
                                FoundFiles.Add (ff)
                            End If
                        Loop
                    End If
                    sDirName = Dir
                Loop
            End If
   
    Execute = FoundFiles.Count
   
End Function

The second I named FilesFound and the code is as follows:

Public FoundFileFullName As String

Public Function AddFile(path As String, fileName As String)
    FoundFileFullName = path & "\" & fileName
End Function


That should do it.

To use it in your code just create the two class modules and then use it as such:

    Dim sFile as String
    Dim fs As New FileSearh

    With fs
        .LookIn = sPath
        .SearchSubFolders = True
        .fileName = "*"
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                sFile = .FoundFiles(i)
                    ' your code here

            Next
        End If
    End With

so it works exactly the same. The only difference I know of is, if the file you're looking for may have any extension use "*"  instead of "*.*" as microsoft put out. I was lazy and just did a like comparison instead of breaking out the file extensions. All others should theoretically work fine i.e. "*.xls" or "*.txt"

That's it. Enjoy!!!!!!!!


James

Simply brilliant!

I gave up searching MSDN for an answer to the vanishing of Filesearch from VBA.

I came across this thread as the top result in a Google search. Maybe I do not know how to search MSDN but I rarely if ever have any success. 

I rely more and more to Google's amazing searching capability.

Thanks for your contribution and Bravo!

Germain

Answer 47

Thaks Jean-Paul, this worked great!

Answer 48

for anyone that cares, I have written a working replacement for FileSearch for Excel 2007. It works almost exeactly the same way, with a few things added. if anyone has suggestions for further additions, let me know.

One thing to note is that you must check the box labeled "Trust access to the VBA project object model" under "Excel Options\Trust Center\Trust Center Settings\Macro Settings" for the auto-referencing to work, or else you must manually add a reference to "Microsoft Scripting Runtime" to your project.

Insert a class module into your project and name it "FileSearch2007", then paste in the following code:

Option Explicit

'Andy Janish 5-26-2010
'
'This class is to be used as a replacement for the "Application.FileSearch" method
'available in Excel 2003 that was deprecated in Excel 2007
'
'Properties:
'1. Filename - filename (with wildcards) to search for (not including directory)
'2. LookIn - parent directory to search through
'3. SearchSubFolders - true means to search through any subfolders found
'4. Sort - true = sort files alphabetically (only applies if subfolders were searched)
'5. FoundFiles - list of files found in the search
'6. FilePaths - list of files with full path included found in search
'7. FileCount - count of the number of files found in the search (UBound(array))
'
'Methods:
'1. NewSearch - clear all previous properties
'2. Script_Ref - create reference to Microsoft Scripting Runtime dll
'3. Search_Sub(curFolder As Folder) - searches through all subfolders of the specified folder
'4. Sort_Files - sorts files alphabetically
'Functions
'1. Execute - run the search for the files

'Declare all property variables private
Private pFileName As String
  'Private pFileType As Integer
Private pLookIn As String
Private pSearchSubFolders As Boolean
Private pSort As Boolean
Private pFoundFiles() As String
Private pFilePaths() As String
Private pFileCount As Integer


'Create methods for accessing and modifying all properties
Public Property Let FileName(Value As String)
  pFileName = Value
End Property

Public Property Let LookIn(Value As String)
  pLookIn = Value
End Property

Public Property Let SearchSubFolders(Value As Boolean)
  pSearchSubFolders = Value
End Property

Public Property Let Sort(Value As Boolean)
  pSort = Value
End Property

Public Property Get FoundFiles(Value As Integer)
  If (Value < pFileCount And Value >= 0) Then
    FoundFiles = pFoundFiles(Value)
  Else
    MsgBox "Error - File index is too high. Only " & pFileCount & " files were found."
    FoundFiles = ""
  End If
End Property

Public Property Get FilePaths(Value As Integer)
  If (Value < pFileCount And Value >= 0) Then
    FilePaths = pFilePaths(Value)
  Else
    MsgBox "Error - File index is too high. Only " & pFileCount & " files were found."
    FilePaths = ""
  End If
End Property

Public Property Get FileCount() As Integer
  FileCount = pFileCount
End Property



Public Sub NewSearch()
'clear any parameters from previous searches
  pFileName = ""
  pLookIn = ""
  pSearchSubFolders = False
  pSort = False
  Erase pFoundFiles
  Erase pFilePaths
  pFileCount = 0
End Sub

Public Function Execute() As Integer
  Dim n As Integer
  Dim InitDir As String
  Dim tempFile As String

  On Error GoTo Execute_Error
  
  'make sure a directory to search was specified
  'and that something is entered for a filename
  If pLookIn = "" Then
    MsgBox "Please specify a directory to search"
  ElseIf pFileName = "" Then
    pFileName = "*"
  End If
  
  'clear any previously found files
  Erase pFoundFiles
  Erase pFilePaths
  pFileCount = 0
  
  'save the initial directory and switch to the search drive\directory
  InitDir = CurDir
  If Mid(pFileName, 2, 1) = ":" Then
    ChDrive Left(pFileName, 2)
  End If
  ChDir pLookIn
  
  'search through the main directory for files matching the filename specified
  tempFile = Dir(pFileName)
  Do While tempFile <> ""
    pFileCount = pFileCount + 1
    ReDim Preserve pFoundFiles(pFileCount)
    ReDim Preserve pFilePaths(pFileCount)
    pFoundFiles(pFileCount - 1) = tempFile
    pFilePaths(pFileCount - 1) = CurDir
    If Right(CurDir, 1) <> "\" Then pFilePaths(pFileCount - 1) = CurDir & "\"
    pFilePaths(pFileCount - 1) = pFilePaths(pFileCount - 1) & tempFile
    tempFile = Dir
  Loop
  
  If pSearchSubFolders Then
    'create reference to "Microsoft Scripting Runtime"
    Call Script_Ref
    
    Dim FS As New FileSystemObject
    Dim FSfolder As Folder
    Set FSfolder = FS.GetFolder(pLookIn)
    
    Call Search_Sub(FSfolder)
    If pSort Then Call Sort_Files
  End If
  ChDrive Left(InitDir, 2)
  ChDir InitDir
  Execute = 1
  Exit Function
  
Execute_Error:
  MsgBox "Error encountered while searching for files"
  Erase pFoundFiles
  Erase pFilePaths
  pFileCount = 0
  ChDrive Left(InitDir, 2)
  ChDir InitDir
  Execute = 0
End Function

Private Sub Script_Ref()
  Dim myWkbk As String
  
  On Error Resume Next
  myWkbk = ThisWorkbook.Name
  With Application.Workbooks(myWkbk).VBProject.References
    .AddFromFile "C:\windows\system32\scrrun.dll"
  End With
End Sub

Private Sub Search_Sub(curFolder As Folder)
  Dim FS As New FileSystemObject
  Dim FSfolder As Folder
  Dim subfolder As Folder
  Dim tempFile As String
  
  'Search the subfolder that was specified,
  'along with any subfolders inside of it
  Set FSfolder = FS.GetFolder(curFolder)
  For Each subfolder In FSfolder.SubFolders
    ChDir subfolder
    tempFile = Dir(pFileName)
    Do While tempFile <> ""
      pFileCount = pFileCount + 1
      ReDim Preserve pFoundFiles(pFileCount)
      ReDim Preserve pFilePaths(pFileCount)
      pFoundFiles(pFileCount - 1) = tempFile
      pFilePaths(pFileCount - 1) = CurDir
      If Right(CurDir, 1) <> "\" Then pFilePaths(pFileCount - 1) = CurDir & "\"
      pFilePaths(pFileCount - 1) = pFilePaths(pFileCount - 1) & tempFile
      tempFile = Dir
    Loop
    'check inside of each subfolder for more subfolders
    'by calling this subroutine recursively
    Call Search_Sub(subfolder)
  Next subfolder
  
  Set FSfolder = Nothing
  Set subfolder = Nothing
End Sub

Private Sub Sort_Files()
  Dim n As Integer
  Dim m As Integer
  Dim temp As String
  
  'Sort all files found (including those from subfolders) alphabetically
  For n = 0 To (pFileCount - 1)
    For m = n To (pFileCount - 1)
      If (UCase(pFoundFiles(m)) < UCase(pFoundFiles(n))) Then
        temp = pFoundFiles(n)
        pFoundFiles(n) = pFoundFiles(m)
        pFoundFiles(m) = temp
        temp = pFilePaths(n)
        pFilePaths(n) = pFilePaths(m)
        pFilePaths(m) = temp
      End If
    Next m
  Next n
End Sub

This should now work just like the original FileSearch. To have this available all the time, make sure the class module above was added to your Personal.xls workbook that loads when Excel starts.

Here's an example of how to use this (the following code should be added to a regular module in your project):

Sub TestFileSearch()
  Dim n As Integer
  Dim Search As FileSearch2007
  Set Search = New FileSearch2007

  With Search
    .NewSearch
    .FileName = "*.xls"
    .LookIn = "C:\"
    .SearchSubFolders = True
    .Sort = True
    If .Execute > 0 Then
      Columns("A:B").ClearContents
      Range("a1").Value = .FileCount
      For n = 1 To .FileCount
        Range("a" & n + 2).Value = .FoundFiles(n - 1)
        Range("b" & n + 2).Value = .FilePaths(n - 1)
      Next n
    End If
  End With
End Sub

Enjoy! 

Answer 49

@janish89

 

I've get an error here:

with the Error "Variable not defined" and ThisWorkbook marked. This error popup only if i set .SearchSubFolders to True

Any thoughts?

Private Sub Script_Ref()

 Dim myWkbk As String

 

 On Error Resume Next

 myWkbk = ThisWorkbook.Name

 With Application.Workbooks(myWkbk).VBProject.References

 .AddFromFile "C:\windows\system32\scrrun.dll"

 End With

End Sub

Answer 50

if you are having issues with the Script_Ref subroutine, you can just manually add the reference rather than playing with the code. Go to Tools/References and check the box next to "Microsoft Scripting Runtime", then remore the whole Script_Ref subroutine from your code. Let me know if the FileSearch2007 code works after that.

Answer 51

Hi I am a complete newby to VBA who has been stranded with this code and I am recieving the same error as all the other 

postees. 

I have tried to implement the changes that have been suggested but am afraid that I have been unsuccesful. 

Any help given would be gratefully appreciated.

Sub Bouton1_QuandClic()
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim fs, f, flname
Dim MyPath
Dim semaine, fichier
Dim exc As New Excel.Application
Dim LaDate As String
Dim NomClasseur, nomfichier, DFU, Location, Model, Typ, FcstID, DUR As String
Dim i, j, lig, col As Integer

Dim Feuil1, Feuil_Synthese As Worksheet
Dim appexcel As Excel.Application
Dim WB1, WB2 As Excel.Workbook

j = 2
Ns = Sheets("Datas").Range("C2")
DFU = Sheets("Datas").Cells(14, 5)
Location = Sheets("Datas").Cells(15, 5)
Model = Sheets("Datas").Cells(16, 5)
Typ = Sheets("Datas").Cells(17, 5)
FcstID = Sheets("Datas").Cells(18, 5)
DUR = Sheets("Datas").Cells(19, 5)

'récupération du chemin courant
MyPath = ActiveWorkbook.Path & "\"

Set fs = CreateObject("Scripting.FileSystemObject")

' Récupère la liste des fichiers dans le répertoire
Set faps = Application.FileSearch
With faps
 .LookIn = MyPath & "ADF Import"
 .Filename = "*.*"
 
 
 
 Workbooks.Add
 Set WB1 = ActiveWorkbook

 Set Feuil1 = WB1.Worksheets(1)

 Feuil1.Cells(1, 1).Value = "*DmdGroup"
 Feuil1.Cells(1, 2).Value = "*DmdUnit"
 Feuil1.Cells(1, 3).Value = "*Loc"
 Feuil1.Cells(1, 4).Value = "*Model"
 Feuil1.Cells(1, 5).Value = "*StartDate"
 Feuil1.Cells(1, 6).Value = "*Type"
 Feuil1.Cells(1, 7).Value = "*FcstID"
 Feuil1.Cells(1, 8).Value = "Qty"
 Feuil1.Cells(1, 9).Value = "Dur"
 
 If .Execute > 0 Then
    
  ' Tant qu'il y a des fichiers dans le répertoire
  For i = 1 To .FoundFiles.Count
    
   flname = .FoundFiles(i)
    
   ' Ouverture du fichier sélectionné
   Workbooks.Open Filename:=flname
    
   Set WB2 = ActiveWorkbook
    
   'sélection de l'onglet Summary
   Set Feuil_Summary = WB2.Worksheets("Summary")
    
   lig = 2
   col = 3
   
   ' Tant qu'il y a des données dans la feuille excel
   Do
    Do
     semaine = Feuil_Summary.Cells(1, col).Value
     DFU = Feuil_Summary.Cells(lig, 2).Value
     Codesku = Feuil_Summary.Cells(lig, 1).Value
     
     Feuil1.Cells(j, 1).Value = DFU
     Feuil1.Cells(j, 2).Value = Codesku
     Feuil1.Cells(j, 3).Value = Location
     Feuil1.Cells(j, 4).Value = Model
     Feuil1.Cells(j, 5).Value = semaine
     Feuil1.Cells(j, 6).Value = Typ
     Feuil1.Cells(j, 7).Value = FcstID
     Feuil1.Cells(j, 8).Value = Format(Feuil_Summary.Cells(lig, col).Value, "00000000000")
     Feuil1.Cells(j, 9).Value = DUR
      '"00000000000"
     j = j + 1
     col = col + 1
    Loop Until Feuil_Summary.Cells(lig, col).Value = ""
     
    lig = lig + 1
    col = 3
     
   Loop Until Feuil_Summary.Cells(lig, col).Value = ""
       
   WB2.Close
  Next i
   
 Else
  MsgBox "There were no files found."
 End If
  

 
End With

 

End Sub

Answer 52

1.  I am trying janish89 's code and am getting the error "User-defined type not defined".  I have the supplied code in a class module named FileSearch2007 in PERSONAL.XLS.  Microsoft Scripting Runtime is referenced.  In my subroutine I have the following variables defined:

Dim itemFile As Integer, dMax As Date, Search As FileSearch2007
Set Search = New FileSearch2007

Now, if I move it to the Class Modules section in my application it then works.  When it comes to Class Modules I'm a total newb so further enlightenment is appreciated.

2.  Next issue is with .FoundFiles.Count. below.  I get a "Argument not optional" error:

Dim itemFile As Integer, dMax As Date, Search As FileSearch2007
Set Search = New FileSearch2007

'With Application.FileSearch
With Search
 .NewSearch
 .LookIn = sDirectory
 .FileName = sSearchExpression 'sFileName
 .SearchSubFolders = False
 .Execute
 'Find the most recent Created/Modified Date
 dMax = #1/1/1901# 'Set default date
 For itemFile = 1 To .FoundFiles.Count
  If dMax < FileDateTime(.FoundFiles(itemFile)) Then
   dMax = FileDateTime(.FoundFiles(itemFile))
   sGetRecentFile = .FoundFiles(itemFile)
  End If
 Next itemFile
End With

End Function

I'm working with .FileCount right now instead of .FoundFiles.Count but am running into other issues so help with this is appreciated.  TIA!

 

 

Answer 53

Hmmm...looks like this work-around doesn't work with UNC path names.

Nice work Microsoft, who's the clown that thought we didn't need this functionality?

Answer 54

Thanks James! It came in very handy!

...but the SearchSubFolders of your class doesn't work though.

I debuged it so as to make it find files within the next level of subfolders (only 1 level):

Create Class FileSearch :

Dim pLookIn As String
Dim pSearchSubFolders As Boolean
Dim pFileName As String

Public FoundFiles As New Collection
Public FoundDirectories As New Collection

Public Property Get LookIn() As String
    LookIn = pLookIn
End Property
Public Property Let LookIn(value As String)
    pLookIn = value
End Property
Public Property Get SearchSubFolders() As Boolean
    SearchSubFolders = pSearchSubFolders
End Property
Public Property Let SearchSubFolders(value As Boolean)
    pSearchSubFolders = value
End Property
Public Property Get fileName() As String
    fileName = pFileName
End Property
Public Property Let fileName(value As String)
    pFileName = value
End Property
Public Function Execute() As Long

    Dim i As Long
    Dim sLookIn As String
    Dim sDirName As String
    Dim sCurDir As String
    Dim sFileName As String
    Dim ff As FilesFound
   
    i = 1
    Set ff = New FilesFound
    sLookIn = LookIn
    sFileName = Dir(sLookIn & "\", vbNormal)
    Do Until Len(sFileName) = 0
        If sFileName Like fileName Then
            ff.AddFile sLookIn, sFileName
            FoundFiles.Add (ff.FoundFileFullName)
        End If
        sFileName = Dir
    Loop
    If SearchSubFolders Then
        sDirName = Dir(sLookIn & "\", vbDirectory)
        Do Until Len(sDirName) = 0
            sCurDir = sLookIn & "\" & sDirName
            If GetAttr(sCurDir) = vbDirectory And sDirName <> "." And sDirName <> ".." Then
                FoundDirectories.Add (sCurDir)
            End If
            sDirName = Dir
        Loop
        Do Until i > FoundDirectories.Count
            sFileName = Dir(FoundDirectories.Item(i) & "\", vbNormal)
            Do Until Len(sFileName) = 0
                If sFileName Like fileName Then
                    ff.AddFile FoundDirectories.Item(i), sFileName
                    FoundFiles.Add (ff.FoundFileFullName)
                End If
                sFileName = Dir
            Loop
            i = i + 1
         Loop
    End If
 Execute = FoundFiles.Count
End Function
Public Function Clear() As Long
    Set FoundFiles = Nothing
    Set FoundDirectories = Nothing
    Set FoundFiles = New Collection
    Set FoundDirectories = New Collection
End Function

Create Class FilesFound :

Public FoundFileFullName As String

Public Function AddFile(path As String, fileName As String)
    FoundFileFullName = path & "\" & fileName
End Function

And then use it in your Module:

    Dim SourceFilesPath As String
    Dim FileString As String
    
    SourceFilesPath = "W:\FolderToSearch\"
    FileString = "*.xls*"
    
    Dim i As Integer
    i = 1
   
    Dim fs As New FileSearch

     With fs
        .LookIn = SourceFilesPath & S
        .SearchSubFolders = True
        .fileName = FileString
        If .Execute > 0 Then
            For j = 1 To .FoundFiles.Count
                Sheets("FilesFound").Cells(i, j).value = .FoundFiles(j)
            Next
        End If
        i = i + 1
        .Clear
    End With
   
    MsgBox "Done"

Answer 55

Okay, after fiddle-faddling with the code (janish89 ) I got it to work but the Class Module needs to be in the same workbook as the code calling it i.e., it can't be called from Personal.xls.  Here's my function that I was able to convert from the depreciated FileSearch.

 

Function sGetRecentFile(sDirectory As String, sSearchExpression As String) As String

'Returns a string that contains the most recent full file path and file name of what's being searched.

'sDirectory = a full file path using UNC e.g., "\\celio\CCREPORTS\Project RAID Reports\KANA\"

'sSearchExpression = any valid file search expression, e.g., "*.xls"

'The given directory (folder) is searched using the search expression given. Out of the list of files

'returned by the search, only the file with the most recent Created/Modified Date is returned.

'Modified date = Created date when a file is first created. After the file has been opened then the

'Modified date gets updated and thus becomes the more recent file.



Dim itemFile As Integer, dMax As Date

Dim Search As FileSearch2007



Set Search = New FileSearch2007

With Search

 .NewSearch

 .LookIn = sDirectory

 .FileName = sSearchExpression 'sFileName

 .SearchSubFolders = False

 .Execute

 'Find the most recent Created/Modified Date

 dMax = #1/1/1901# 'Set default date

 For itemFile = 1 To .FileCount

  If dMax < FileDateTime(.FilePaths(itemFile)) Then

   dMax = FileDateTime(.FilePaths(itemFile))

   sGetRecentFile = .FilePaths(itemFile)

  End If

 Next itemFile

End With

Set Search = Nothing

End Function

 

Add an equal sign to the first condition for both these Properties (find the Properties and replace them with the below code):

 

Public Property Get FoundFiles(Value As Integer)

 If (Value <= pFileCount And Value >= 0) Then

  FoundFiles = pFoundFiles(Value)

 Else

  MsgBox "Error - File index is too high. Only " & pFileCount & " files were found."

  FoundFiles = ""

 End If

End Property





Public Property Get FilePaths(Value As Integer)

 If (Value <= pFileCount And Value >= 0) Then

  FilePaths = pFilePaths(Value)

 Else

  MsgBox "Error - File index is too high. Only " & pFileCount & " files were found."

  FilePaths = ""

 End If

End Property

 

Finally, change the Execute Method by removing the -1 from the lines in the DO WHILE...LOOP (change already made in my below code snippet):

 

 pFoundFiles(pFileCount) = tempFile

 pFilePaths(pFileCount) = CurDir

 If Right(CurDir, 1) <> "\" Then pFilePaths(pFileCount) = CurDir & "\"

 pFilePaths(pFileCount) = pFilePaths(pFileCount) & tempFile

Making these changes allowed my code to work properly.

*dang this editor is buggy!

Answer 56

In 2007 I published a book (Programmare Office 2007 -> Programming Office 2007) for an italian magazine.

I wrote a class to be used instead of FileSearch (the purpose is the same of the code proposed by janish89)

My proposed class is named myFileSearch; use it like this example:

 

 Dim mFileSearch As New myFileSearch



 With mFileSearch



  .NewSearch



  .LookIn = cartella



  .FileType = msoFileTypeWordDocuments



  .SearchSubFolders = sottocartelle



  .Execute



 End With

instead of

 

With Application.FileSearch



  .NewSearch



  .LookIn = cartella



  .FileType = msoFileTypeWordDocuments



  .SearchSubFolders = sottocartelle



  .Execute



 End With

The class can be download from page: http://ivenuti.altervista.org/risorse/vba.htm

It is released as free software. Feel free to use and modify it in any of your projects.

If you modify it I'd like to receive your improvements, but it isn't mandatory.

Thanks

Answer 57

Upon further review. This code works great (period).

Answer 58

This has to be the most useful thread yet on filesearch alternatives. But i still cant find much on anything open most recent files in directories including subfolders. I’ve tried working around this but I have not been able to. Could anyone help me convert this over to 2007-2010 capable code?

Option Explicit
Sub Test()
    Dim pathname As String
    Dim snippet As String
    Dim wb As Workbook
    pathname = "C:\"
    snippet = "test "     'Notice the "space" after test. This will let it pull
                               'the files test 2001-01-01

    Set wb = NewestBookWithNameSnippet(pathname, snippet)
    wb.Activate


End Sub

Function NewestBookWithNameSnippet(pathname As String, nameSnippet As String) As Workbook
    'Function assumes that the date is in the far right side of workbook name
    'Be careful of Capitilization of The namesnippet and be sure to include any spaces between  the
    'name snippet and the date.
    Dim fs As FileSearch, iCount As Long
    Dim MyFile  As String
    Dim TestFile As String
    Dim Largestdate As Date
    Dim testDate As Date

    Set fs = Application.FileSearch
    With fs
        .SearchSubFolders = False                ' set to true if you want sub-folders included
        .FileType = msoFileTypeExcelWorkbooks    'just Excel files
        .LookIn = pathname
        If .Execute > 0 Then

            For iCount = 1 To .FoundFiles.Count
                TestFile = .FoundFiles(iCount)
                Debug.Print InStr(TestFile, nameSnippet)
                If InStr(TestFile, nameSnippet) <> 0 Then
                    testDate = Mid(.FoundFiles(iCount), Len(pathname & nameSnippet) + 1, _
                                    Len(.FoundFiles(iCount)) - Len(pathname & nameSnippet) - 4) ' "-4" is for .xls
                    If CDate(testDate) > CDate(Largestdate) Then
                        Largestdate = testDate
                        MyFile = TestFile
                    End If
                End If
            Next iCount
        Else
             MsgBox "No files found"
             Exit Function
        End If
    End With

    Set fs = Nothing
    Set NewestBookWithNameSnippet = Workbooks.Open(MyFile)

End Function

Answer 59

After trying to implement janish89  & Air_Cooled_Nut answers to get things rolling i kept getting more and more errors. Im new to all this and just wingin atm. I added Nuts function and property changes to the class module created using Janish89 code and i tried loading the Sub TestFileSearch() to make sure everything was running right but it gives me an "Type mismath" error and breaks on:

 If .Execute > 0 Then

Any tell what thing im doing wrong?

Answer 60

Hi,

I only have 2003 so this is just advice rather than an absolute answer. In the VBA Editor use the Object Browser and do a search (or browse) for the Application object. See if the FileSearch object is there.

If that doesn't help can you find a feature on the GUI to do the File Search. If you can record a macro and that will give you an idea of what legacy code to use.

I hope that helps.

I know this post is more than 4 years old but I wonder who marked it as an answer?  It contain absolutely *nothing* that could even remotely help someone using Office 2007 address the issue of Microsoft depracating FileSearch! {grin}

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 61

Great code, PrizmP, but I only get it to find 11 files in 3 subdirectories out of 100+ files in 30+ subdirectories. No error messages, always the same 11 files, not sure why or where it decides to end the loop. Any thoughts? I'm getting desperate...

Thanks,
Uta

Answer 62

Hi,

 

Im trying to use the modified code by Air_Cooled_Nut which works with a full file path using UNC but that does not seem to work, it always points to the "C:\Documents and Settings\username\My Documents". Any ideas what is wrong?

 

Thanks,

 

Answer 63

I have been using this code for some time, however, I cannot get it to work with SEARCHSUBFOLDERS set to True. It only gives me files in the root directory. Any ideas?

 

Thanks.

Answer 64

Hello everyone, I do not know that much about VB, but I really really really need some help. I have this code that works perfect in excel 2003, but it does not work in 2007 because of the Application.FileSearch , and I was wondering if someone can help me out, the code I have is this one:

Sub ConsolidateFinal()
    Dim vaFileName As Variant, wbkData As Workbook
    Dim vaDataTotal As Variant, vaDataWbk As Variant, lRow As Long, lCol As Long
    Dim vaDataTotal02 As Variant, vaDataWbk02 As Variant
    Dim vaDataTotal03 As Variant, vaDataWbk03 As Variant
    Dim vaDataTotal04 As Variant, vaDataWbk04 As Variant
    Dim vaDataTotal05 As Variant, vaDataWbk05 As Variant
    Dim vaDataTotal06 As Variant, vaDataWbk06 As Variant, qRow As Long, qCol As Long
    Dim vaDataTotal07 As Variant, vaDataWbk07 As Variant
    Dim vaDataTotal08 As Variant, vaDataWbk08 As Variant
    Dim vaDataTotal09 As Variant, vaDataWbk09 As Variant
    Dim vaDataTotal10 As Variant, vaDataWbk10 As Variant
    Dim vaDataTotal11 As Variant, vaDataWbk11 As Variant
    Dim vaDataTotal12 As Variant, vaDataWbk12 As Variant
    Dim fname
    Dim fname2
    fname = "C:\Documents and settings\" & Environ("username") & "\Desktop\StopHIVAIDS"
    fname2 = "Macintosh HD:Users:Username:Desktop:StopHIVAIDS"
   
    With Application.FileSearch
        .NewSearch
        .LookIn = fname
        .LookIn = fname2
       
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then

            Application.ScreenUpdating = False
            ReDim vaDataTotal(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal02(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal03(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal04(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal05(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal06(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal07(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal08(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal09(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal10(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal11(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal12(1 To 2, 1 To 15) As Variant
            For Each vaFileName In .FoundFiles

                Set wbkData = Workbooks.Open(Filename:=vaFileName)

                With wbkData
                    vaDataWbk = .Worksheets("Data").Range("C7:Q7").Value
                    vaDataWbk02 = .Worksheets("Data").Range("C10:Q10").Value
                    vaDataWbk03 = .Worksheets("Data").Range("C16:Q16").Value
                    vaDataWbk04 = .Worksheets("Data").Range("C22:Q22").Value
                    vaDataWbk05 = .Worksheets("Data").Range("C26:Q26").Value
                    vaDataWbk06 = .Worksheets("Data").Range("C30:Q31").Value
                    vaDataWbk07 = .Worksheets("Data").Range("C35:Q36").Value
                    vaDataWbk08 = .Worksheets("Data").Range("C41:Q42").Value
                    vaDataWbk09 = .Worksheets("Data").Range("C45:Q46").Value
                    vaDataWbk10 = .Worksheets("Data").Range("C49:Q50").Value
                    vaDataWbk11 = .Worksheets("Data").Range("C53:Q54").Value
                    vaDataWbk12 = .Worksheets("Data").Range("C57:Q58").Value

                    For lCol = 1 To 15
                        For lRow = 1 To 1
                            vaDataTotal(lRow, lCol) = _
                                vaDataTotal(lRow, lCol) + vaDataWbk(lRow, lCol)
                            vaDataTotal02(lRow, lCol) = _
                                vaDataTotal02(lRow, lCol) + vaDataWbk02(lRow, lCol)
                            vaDataTotal03(lRow, lCol) = _
                                vaDataTotal03(lRow, lCol) + vaDataWbk03(lRow, lCol)
                            vaDataTotal04(lRow, lCol) = _
                                vaDataTotal04(lRow, lCol) + vaDataWbk04(lRow, lCol)
                            vaDataTotal05(lRow, lCol) = _
                                vaDataTotal05(lRow, lCol) + vaDataWbk05(lRow, lCol)
                        Next lRow
                    Next lCol
                    For qCol = 1 To 15
                        For qRow = 1 To 2
                            vaDataTotal06(qRow, qCol) = _
                                vaDataTotal06(qRow, qCol) + vaDataWbk06(qRow, qCol)
                            vaDataTotal07(qRow, qCol) = _
                                vaDataTotal07(qRow, qCol) + vaDataWbk07(qRow, qCol)
                            vaDataTotal08(qRow, qCol) = _
                                vaDataTotal08(qRow, qCol) + vaDataWbk08(qRow, qCol)
                            vaDataTotal09(qRow, qCol) = _
                                vaDataTotal09(qRow, qCol) + vaDataWbk09(qRow, qCol)
                            vaDataTotal10(qRow, qCol) = _
                                vaDataTotal10(qRow, qCol) + vaDataWbk10(qRow, qCol)
                            vaDataTotal11(qRow, qCol) = _
                                vaDataTotal11(qRow, qCol) + vaDataWbk11(qRow, qCol)
                            vaDataTotal12(qRow, qCol) = _
                                vaDataTotal12(qRow, qCol) + vaDataWbk12(qRow, qCol)
                        Next qRow
                    Next qCol

                    .Close savechanges:=False

                End With
            Next vaFileName
            ThisWorkbook.Worksheets("Data").Range("C7:Q7").Value = vaDataTotal
            ThisWorkbook.Worksheets("Data").Range("C10:Q10").Value = vaDataTotal02
            ThisWorkbook.Worksheets("Data").Range("C16:Q16").Value = vaDataTotal03
            ThisWorkbook.Worksheets("Data").Range("C22:Q22").Value = vaDataTotal04
            ThisWorkbook.Worksheets("Data").Range("C26:Q26").Value = vaDataTotal05
            ThisWorkbook.Worksheets("Data").Range("C30:Q31").Value = vaDataTotal06
            ThisWorkbook.Worksheets("Data").Range("C35:Q36").Value = vaDataTotal07
            ThisWorkbook.Worksheets("Data").Range("C41:Q42").Value = vaDataTotal08
            ThisWorkbook.Worksheets("Data").Range("C45:Q46").Value = vaDataTotal09
            ThisWorkbook.Worksheets("Data").Range("C49:Q50").Value = vaDataTotal10
            ThisWorkbook.Worksheets("Data").Range("C53:Q54").Value = vaDataTotal11
            ThisWorkbook.Worksheets("Data").Range("C57:Q58").Value = vaDataTotal12
            Application.ScreenUpdating = True
        Else
            MsgBox "There were no Excel files found."
        End If
    End With

End Sub

Please if someone can help me to get this to work I really appreciate it a lot!!! I have been trying to fix it for two days in a row, and I can't, and my job kinda depends on it, I am desperate and don't know what else to do.

THANK YOU!

Answer 65

Have you looked at the myriad of answers in this discussion that address alternatives and replacements for FileSearch?

I'll add one more. {grin}

Put the searchForFiles procedure from http://www.tushar-mehta.com/publish_train/xl_vba_cases/process_all_files_in_folder.htm in a standard module.  Please remember to include the comments above the subroutine.

Then, put the code below in a separate module.  Run the getGoing subroutine.  Given that I don't have any files with the data that you have the code is largely *untested.*

Option Explicit
  Dim vaDataTotal As Variant, vaDataWbk As Variant
  Dim vaDataTotal02 As Variant, vaDataWbk02 As Variant
  Dim vaDataTotal03 As Variant, vaDataWbk03 As Variant
  Dim vaDataTotal04 As Variant, vaDataWbk04 As Variant
  Dim vaDataTotal05 As Variant, vaDataWbk05 As Variant
  Dim vaDataTotal06 As Variant, vaDataWbk06 As Variant
  Dim vaDataTotal07 As Variant, vaDataWbk07 As Variant
  Dim vaDataTotal08 As Variant, vaDataWbk08 As Variant
  Dim vaDataTotal09 As Variant, vaDataWbk09 As Variant
  Dim vaDataTotal10 As Variant, vaDataWbk10 As Variant
  Dim vaDataTotal11 As Variant, vaDataWbk11 As Variant
  Dim vaDataTotal12 As Variant, vaDataWbk12 As Variant
Sub getGoing()
  Application.ScreenUpdating = False
  ReDim vaDataTotal(1 To 1, 1 To 15) As Variant
  ReDim vaDataTotal02(1 To 1, 1 To 15) As Variant
  ReDim vaDataTotal03(1 To 1, 1 To 15) As Variant
  ReDim vaDataTotal04(1 To 1, 1 To 15) As Variant
  ReDim vaDataTotal05(1 To 1, 1 To 15) As Variant
  ReDim vaDataTotal06(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal07(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal08(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal09(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal10(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal11(1 To 2, 1 To 15) As Variant
  ReDim vaDataTotal12(1 To 2, 1 To 15) As Variant
  
  Dim fName As String
  If InStr(1, Application.OperatingSystem, "Windows", vbTextCompare) > 0 Then
    fName = "C:\Documents and settings\" & Environ("username") & "\Desktop\StopHIVAIDS"
  Else
    fName = "Macintosh HD:Users:Username:Desktop:StopHIVAIDS"
    End If
  searchForFiles fName, "processADataFile", "*.xls", False
  
  ThisWorkbook.Worksheets("Data").Range("C7:Q7").Value = vaDataTotal
  ThisWorkbook.Worksheets("Data").Range("C10:Q10").Value = vaDataTotal02
  ThisWorkbook.Worksheets("Data").Range("C16:Q16").Value = vaDataTotal03
  ThisWorkbook.Worksheets("Data").Range("C22:Q22").Value = vaDataTotal04
  ThisWorkbook.Worksheets("Data").Range("C26:Q26").Value = vaDataTotal05
  ThisWorkbook.Worksheets("Data").Range("C30:Q31").Value = vaDataTotal06
  ThisWorkbook.Worksheets("Data").Range("C35:Q36").Value = vaDataTotal07
  ThisWorkbook.Worksheets("Data").Range("C41:Q42").Value = vaDataTotal08
  ThisWorkbook.Worksheets("Data").Range("C45:Q46").Value = vaDataTotal09
  ThisWorkbook.Worksheets("Data").Range("C49:Q50").Value = vaDataTotal10
  ThisWorkbook.Worksheets("Data").Range("C53:Q54").Value = vaDataTotal11
  ThisWorkbook.Worksheets("Data").Range("C57:Q58").Value = vaDataTotal12
  Application.ScreenUpdating = True
  End Sub
Sub processADataFile(ByVal vaFileName As String)
  Dim wbkData As Workbook
  Dim lRow As Long, lCOl As Long, _
    qRow As Long, qCol As Long
  Debug.Print vaFileName
  'GoTo XIT
  Set wbkData = Workbooks.Open(Filename:=vaFileName)
  With wbkData
  vaDataWbk = .Worksheets("Data").Range("C7:Q7").Value
  vaDataWbk02 = .Worksheets("Data").Range("C10:Q10").Value
  vaDataWbk03 = .Worksheets("Data").Range("C16:Q16").Value
  vaDataWbk04 = .Worksheets("Data").Range("C22:Q22").Value
  vaDataWbk05 = .Worksheets("Data").Range("C26:Q26").Value
  vaDataWbk06 = .Worksheets("Data").Range("C30:Q31").Value
  vaDataWbk07 = .Worksheets("Data").Range("C35:Q36").Value
  vaDataWbk08 = .Worksheets("Data").Range("C41:Q42").Value
  vaDataWbk09 = .Worksheets("Data").Range("C45:Q46").Value
  vaDataWbk10 = .Worksheets("Data").Range("C49:Q50").Value
  vaDataWbk11 = .Worksheets("Data").Range("C53:Q54").Value
  vaDataWbk12 = .Worksheets("Data").Range("C57:Q58").Value
  For lCOl = 1 To 15
    For lRow = 1 To 1
      vaDataTotal(lRow, lCOl) = _
        vaDataTotal(lRow, lCOl) + vaDataWbk(lRow, lCOl)
      vaDataTotal02(lRow, lCOl) = _
        vaDataTotal02(lRow, lCOl) + vaDataWbk02(lRow, lCOl)
      vaDataTotal03(lRow, lCOl) = _
        vaDataTotal03(lRow, lCOl) + vaDataWbk03(lRow, lCOl)
      vaDataTotal04(lRow, lCOl) = _
        vaDataTotal04(lRow, lCOl) + vaDataWbk04(lRow, lCOl)
      vaDataTotal05(lRow, lCOl) = _
        vaDataTotal05(lRow, lCOl) + vaDataWbk05(lRow, lCOl)
      Next lRow
    Next lCOl
  For qCol = 1 To 15
    For qRow = 1 To 2
      vaDataTotal06(qRow, qCol) = _
        vaDataTotal06(qRow, qCol) + vaDataWbk06(qRow, qCol)
      vaDataTotal07(qRow, qCol) = _
        vaDataTotal07(qRow, qCol) + vaDataWbk07(qRow, qCol)
      vaDataTotal08(qRow, qCol) = _
        vaDataTotal08(qRow, qCol) + vaDataWbk08(qRow, qCol)
      vaDataTotal09(qRow, qCol) = _
        vaDataTotal09(qRow, qCol) + vaDataWbk09(qRow, qCol)
      vaDataTotal10(qRow, qCol) = _
        vaDataTotal10(qRow, qCol) + vaDataWbk10(qRow, qCol)
      vaDataTotal11(qRow, qCol) = _
        vaDataTotal11(qRow, qCol) + vaDataWbk11(qRow, qCol)
      vaDataTotal12(qRow, qCol) = _
        vaDataTotal12(qRow, qCol) + vaDataWbk12(qRow, qCol)
      Next qRow
    Next qCol
  .Close savechanges:=False
    End With
XIT:
  End Sub

 

Hello everyone, I do not know that much about VB, but I really really really need some help. I have this code that works perfect in excel 2003, but it does not work in 2007 because of the Application.FileSearch , and I was wondering if someone can help me out, the code I have is this one:

Sub ConsolidateFinal()
    Dim vaFileName As Variant, wbkData As Workbook
    Dim vaDataTotal As Variant, vaDataWbk As Variant, lRow As Long, lCol As Long
    Dim vaDataTotal02 As Variant, vaDataWbk02 As Variant
    Dim vaDataTotal03 As Variant, vaDataWbk03 As Variant
    Dim vaDataTotal04 As Variant, vaDataWbk04 As Variant
    Dim vaDataTotal05 As Variant, vaDataWbk05 As Variant
    Dim vaDataTotal06 As Variant, vaDataWbk06 As Variant, qRow As Long, qCol As Long
    Dim vaDataTotal07 As Variant, vaDataWbk07 As Variant
    Dim vaDataTotal08 As Variant, vaDataWbk08 As Variant
    Dim vaDataTotal09 As Variant, vaDataWbk09 As Variant
    Dim vaDataTotal10 As Variant, vaDataWbk10 As Variant
    Dim vaDataTotal11 As Variant, vaDataWbk11 As Variant
    Dim vaDataTotal12 As Variant, vaDataWbk12 As Variant
    Dim fname
    Dim fname2
    fname = "C:\Documents and settings\" & Environ("username") & "\Desktop\StopHIVAIDS"
    fname2 = "Macintosh HD:Users:Username:Desktop:StopHIVAIDS"
   
    With Application.FileSearch
        .NewSearch
        .LookIn = fname
        .LookIn = fname2
       
        .SearchSubFolders = False
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then

            Application.ScreenUpdating = False
            ReDim vaDataTotal(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal02(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal03(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal04(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal05(1 To 1, 1 To 15) As Variant
            ReDim vaDataTotal06(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal07(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal08(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal09(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal10(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal11(1 To 2, 1 To 15) As Variant
            ReDim vaDataTotal12(1 To 2, 1 To 15) As Variant
            For Each vaFileName In .FoundFiles

                Set wbkData = Workbooks.Open(Filename:=vaFileName)

                With wbkData
                    vaDataWbk = .Worksheets("Data").Range("C7:Q7").Value
                    vaDataWbk02 = .Worksheets("Data").Range("C10:Q10").Value
                    vaDataWbk03 = .Worksheets("Data").Range("C16:Q16").Value
                    vaDataWbk04 = .Worksheets("Data").Range("C22:Q22").Value
                    vaDataWbk05 = .Worksheets("Data").Range("C26:Q26").Value
                    vaDataWbk06 = .Worksheets("Data").Range("C30:Q31").Value
                    vaDataWbk07 = .Worksheets("Data").Range("C35:Q36").Value
                    vaDataWbk08 = .Worksheets("Data").Range("C41:Q42").Value
                    vaDataWbk09 = .Worksheets("Data").Range("C45:Q46").Value
                    vaDataWbk10 = .Worksheets("Data").Range("C49:Q50").Value
                    vaDataWbk11 = .Worksheets("Data").Range("C53:Q54").Value
                    vaDataWbk12 = .Worksheets("Data").Range("C57:Q58").Value

                    For lCol = 1 To 15
                        For lRow = 1 To 1
                            vaDataTotal(lRow, lCol) = _
                                vaDataTotal(lRow, lCol) + vaDataWbk(lRow, lCol)
                            vaDataTotal02(lRow, lCol) = _
                                vaDataTotal02(lRow, lCol) + vaDataWbk02(lRow, lCol)
                            vaDataTotal03(lRow, lCol) = _
                                vaDataTotal03(lRow, lCol) + vaDataWbk03(lRow, lCol)
                            vaDataTotal04(lRow, lCol) = _
                                vaDataTotal04(lRow, lCol) + vaDataWbk04(lRow, lCol)
                            vaDataTotal05(lRow, lCol) = _
                                vaDataTotal05(lRow, lCol) + vaDataWbk05(lRow, lCol)
                        Next lRow
                    Next lCol
                    For qCol = 1 To 15
                        For qRow = 1 To 2
                            vaDataTotal06(qRow, qCol) = _
                                vaDataTotal06(qRow, qCol) + vaDataWbk06(qRow, qCol)
                            vaDataTotal07(qRow, qCol) = _
                                vaDataTotal07(qRow, qCol) + vaDataWbk07(qRow, qCol)
                            vaDataTotal08(qRow, qCol) = _
                                vaDataTotal08(qRow, qCol) + vaDataWbk08(qRow, qCol)
                            vaDataTotal09(qRow, qCol) = _
                                vaDataTotal09(qRow, qCol) + vaDataWbk09(qRow, qCol)
                            vaDataTotal10(qRow, qCol) = _
                                vaDataTotal10(qRow, qCol) + vaDataWbk10(qRow, qCol)
                            vaDataTotal11(qRow, qCol) = _
                                vaDataTotal11(qRow, qCol) + vaDataWbk11(qRow, qCol)
                            vaDataTotal12(qRow, qCol) = _
                                vaDataTotal12(qRow, qCol) + vaDataWbk12(qRow, qCol)
                        Next qRow
                    Next qCol

                    .Close savechanges:=False

                End With
            Next vaFileName
            ThisWorkbook.Worksheets("Data").Range("C7:Q7").Value = vaDataTotal
            ThisWorkbook.Worksheets("Data").Range("C10:Q10").Value = vaDataTotal02
            ThisWorkbook.Worksheets("Data").Range("C16:Q16").Value = vaDataTotal03
            ThisWorkbook.Worksheets("Data").Range("C22:Q22").Value = vaDataTotal04
            ThisWorkbook.Worksheets("Data").Range("C26:Q26").Value = vaDataTotal05
            ThisWorkbook.Worksheets("Data").Range("C30:Q31").Value = vaDataTotal06
            ThisWorkbook.Worksheets("Data").Range("C35:Q36").Value = vaDataTotal07
            ThisWorkbook.Worksheets("Data").Range("C41:Q42").Value = vaDataTotal08
            ThisWorkbook.Worksheets("Data").Range("C45:Q46").Value = vaDataTotal09
            ThisWorkbook.Worksheets("Data").Range("C49:Q50").Value = vaDataTotal10
            ThisWorkbook.Worksheets("Data").Range("C53:Q54").Value = vaDataTotal11
            ThisWorkbook.Worksheets("Data").Range("C57:Q58").Value = vaDataTotal12
            Application.ScreenUpdating = True
        Else
            MsgBox "There were no Excel files found."
        End If
    End With

End Sub

Please if someone can help me to get this to work I really appreciate it a lot!!! I have been trying to fix it for two days in a row, and I can't, and my job kinda depends on it, I am desperate and don't know what else to do.

THANK YOU!

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 66

Thank you soooo much, it worked perfectly!!! I have one more question, how can I add a message, so if there are no excel files in the folder, it will give me a message with something like "No excel messages in folder" is that possible?

Again, thank you so much, you are a life saver Tushar Mehta!

Answer 67

1) Just before the

Sub getGoing()

add

Dim NbrFilesProcessed As Long

2) Replace all the assignments

ThisWorkbook.Worksheets("Data")... 

with

  If NbrFilesProcessed = 0 Then
    MsgBox "No files processed"
  Else
    ThisWorkbook.Worksheets("Data").Range("C7:Q7").Value = vaDataTotal
    ThisWorkbook.Worksheets("Data").Range("C10:Q10").Value = vaDataTotal02
    ThisWorkbook.Worksheets("Data").Range("C16:Q16").Value = vaDataTotal03
    ThisWorkbook.Worksheets("Data").Range("C22:Q22").Value = vaDataTotal04
    ThisWorkbook.Worksheets("Data").Range("C26:Q26").Value = vaDataTotal05
    ThisWorkbook.Worksheets("Data").Range("C30:Q31").Value = vaDataTotal06
    ThisWorkbook.Worksheets("Data").Range("C35:Q36").Value = vaDataTotal07
    ThisWorkbook.Worksheets("Data").Range("C41:Q42").Value = vaDataTotal08
    ThisWorkbook.Worksheets("Data").Range("C45:Q46").Value = vaDataTotal09
    ThisWorkbook.Worksheets("Data").Range("C49:Q50").Value = vaDataTotal10
    ThisWorkbook.Worksheets("Data").Range("C53:Q54").Value = vaDataTotal11
    ThisWorkbook.Worksheets("Data").Range("C57:Q58").Value = vaDataTotal12
    Application.ScreenUpdating = True
    End If

and

3) In

Sub processADataFile(ByVal vaFileName As String)

just before

 Debug.Print vaFileName

add

 NbrFilesProcessed = NbrFilesProcessed + 1

 

Thank you soooo much, it worked perfectly!!! I have one more question, how can I add a message, so if there are no excel files in the folder, it will give me a message with something like "No excel messages in folder" is that possible?

Again, thank you so much, you are a life saver Tushar Mehta!

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 68

Again, thank you so much, it worked like a charm!!!! You rock!!!

Answer 69

Again, thank you so much, it worked like a charm!!!! You rock!!!

You are welcome.

Take a moment to mark the posts as answers.

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 70

Hello Tushar Mehta,

Sorry to bother you so much, but maybe you can help me once more. All the workbooks that open and copy the info, they have other sheets with one chart per sheet, is it posible to copy each chart of each document and then have all the chart1 of all the documents copied and paste them in one sheet of the cosolidated workbook, then all the chart2 copied in a different sheet and so forth. And on the top of each sheet have the chart1 of that consolidated document as the main chart folowed by all the other charts? small size of course.

I don't know if I have explained myself, hahahaha. I have searched and searched and cannot find how to do it. Well, let me know if you can help me. Thank you soooo much.

Answer 71

Anybody can tell me how to modify this code to make it work?

 

With Application.FileSearch
            .NewSearch
            .LookIn = Path
            .SearchSubFolders = True
            .Filename = FName_Short
            .FileType = msoFileTypeAllFiles
            If .Execute() > 0 Then
                For i = 1 To .FoundFiles.Count
                    If MsgBox("Do you want to overwrite existing  " + .FoundFiles(i) + _
                        "?", vbYesNo) = vbNo Then
                        GoTo 10
                    End If
                Next i
            End If
        End With

Answer 72

Hello everyone,

Ok, so I was able to copy all the charts as images to the tabs, but now when it pastes them, they are getting pasted on on top of the other, is there a way I can tell it to paste the first image in A1, the second image in K1, the third image in A20 and so furth? Any help would be greattly appreciated, thank you!

Answer 73

Hello everyone,

Ok, so I was able to copy all the charts as images to the tabs, but now when it pastes them, they are getting pasted on on top of the other, is there a way I can tell it to paste the first image in A1, the second image in K1, the third image in A20 and so furth? Any help would be greattly appreciated, thank you!

Use the lightly tested

Option Explicit
Sub relocateObj()
  With ActiveSheet.Shapes 'adjust to use the destination sheet rather than activesheet
  Dim aCell As Range
  Set aCell = Cells(((.Count - 1) \ 2) * 19 + 1, ((.Count - 1) Mod 2) * 10 + 1)
  With .Item(.Count)
  .Left = aCell.Left
  .Top = aCell.Top
    End With
    End With
  End Sub

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 74

Thanks Tushar,

I tried the macro and it gives me an error: Method 'Cels' of object '_Global' failed.

This is what I have to paste the graphs, and re-size them. They get pasted one on top of the other. Is it here were I need to paste your code? I tried it but it still gives me that error.

Sub SizeandPosition()
Dim Wef As Workbook

    Set Wef = Workbooks("Test.xlsm")
    Wef.Activate
   
          Worksheets("Sheet2").Activate

    Range("A1").Select

    ActiveSheet.Paste
   
Dim myChtObj As Object
Dim myInput As String

For Each myChtObj In ActiveSheet.DrawingObjects
myChtObj.Width = 500
myChtObj.Height = 450
Next myChtObj

End Sub

Before this, I am using the code you sent me before, and added this, just before .Close savechanges:=False and after Next qCol:

    Sheets("Sheet1").Select
ActiveChart.ChartArea.Copy
 
  Call SizeandPosition

That way it copies the graphs and when it calls the other sub, it pastes them, and then comes back and closes the files. I really don't know if this is the best way to do it, but it worked, but as I said it pastes them one on top of the other.

Thank you soo much, please help me.

Answer 75

Cells not Cels.

Also, if the sheet is not the activesheet you should adjust to reference to Cells(...) to mySheet.Cells(...) where mySheet is a variable that refers to the correct sheet.

Thanks Tushar,

I tried the macro and it gives me an error: Method 'Cels' of object '_Global' failed.

This is what I have to paste the graphs, and re-size them. They get pasted one on top of the other. Is it here were I need to paste your code? I tried it but it still gives me that error.

Sub SizeandPosition()
Dim Wef As Workbook

    Set Wef = Workbooks("Test.xlsm")
    Wef.Activate
   
          Worksheets("Sheet2").Activate

    Range("A1").Select

    ActiveSheet.Paste
   
Dim myChtObj As Object
Dim myInput As String

For Each myChtObj In ActiveSheet.DrawingObjects
myChtObj.Width = 500
myChtObj.Height = 450
Next myChtObj

End Sub

Before this, I am using the code you sent me before, and added this, just before .Close savechanges:=False and after Next qCol:

    Sheets("Sheet1").Select
ActiveChart.ChartArea.Copy
 
  Call SizeandPosition

That way it copies the graphs and when it calls the other sub, it pastes them, and then comes back and closes the files. I really don't know if this is the best way to do it, but it worked, but as I said it pastes them one on top of the other.

Thank you soo much, please help me.

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 76

It is the active sheet, but I tried changing that as well, and when the graph is not selected it gives me no error, but nothing happens, I think I am putting the code in the wrong place. Were should it be? thank you sooooo much.

Answer 77

It is the active sheet, but I tried changing that as well, and when the graph is not selected it gives me no error, but nothing happens, I think I am putting the code in the wrong place. Were should it be? thank you sooooo much.

It should be after you do the paste.

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 78

Thank you Tushar,

I just realized something, it is not pasting correctly :(  Right now I have it like this:

 vaDataTotal12(qRow, qCol) = _
        vaDataTotal12(qRow, qCol) + vaDataWbk12(qRow, qCol)
      Next qRow
    Next qCol
 

    Sheets("Sheet1").Select
ActiveChart.ChartArea.Copy

  Call Test1

    Sheets("Sheet2").Select
ActiveChart.ChartArea.Copy

 
  Call Test2

  .Close savechanges:=False

The first part works great, it copies all the individual charts of sheet1 of each file, and pastes them correctly in a sheet of the consolidated document. Then when it goes to copy the graphs of sheet2, it does not copy the individual graphs of the files, it copies the graphs from the consolidated document, and pastes ten copies of it... Please help, what am I doing wrong?

Thank you once more for your help!!

Answer 79

Thank you.  Rebuilding the class is a great idea and works well.

Thanks again.

Answer 80

Hi again,

So everything is working great, the only thing is that when tested in excel 2007, the code:

Option Explicit
Sub relocateObj()
 With ActiveSheet.Shapes Dim aCell As Range
 Set aCell = Cells(((.Count - 1) \ 2) * 19 + 1, ((.Count - 1) Mod 2) * 10 + 1)
 With .Item(.Count)
 .Left = aCell.Left
 .Top = aCell.Top
  End With
  End With
 End Sub

Does not work, it does nothing to the charts that have been pasted. Is there anything else I can use intead of .Shapes so that it will recognize the charts in excel 2007? it works great in 2003 but not in 2007. Thank you in advance for any help

Answer 81

As well, does anyone know why Excell 2007 randomly changes the tab names to chart1, chart2... when I close the file and open it again, it has the correct names again. It is wierd. Well if anyone know, thank you sooo much.

Answer 82

Hi, Can someone help me with a replacement for this FileSearch, I will really appreciate the help or the ideas, I looked through the posts here they were helpful, but I dont know if they will work fine in my code.

 

The help is highly appreciated

 

'read case number and define output file name

    Windows(bndryfile).Activate

        ActiveCell.Offset(0, 11).Select

        casenum = ActiveCell

        caselength = Len(casenum)

        yft_casenum = "000000"

        yft_casenum = Left(yft_casenum, 6 - caselength) & casenum

        fname = YFT_model & ".033." & yft_casenum

'Open YFT output file

    With Application.FileSearch

        .NewSearch

        .LookIn = folder

        .SearchSubFolders = False

        .Filename = fname

        .MatchTextExactly = True

        .FileType = msoFileTypeAllFiles

        .Execute

        numfiles = .FoundFiles.Count

        If numfiles = 0 Then

            nofile = MsgBox("File: " & fname & " not found!" & Chr(13) & Chr(13) & " -Check cell B5 in BC spreadsheet" & Chr(13) & " -Please try again", vbCritical)

            Exit Sub

        End If

    End With

   

    ChDir (folder)

        Workbooks.OpenText Filename:= _

        folder & "\" & fname, Origin _

        :=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _

        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False _

        , Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _

        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

 

Answer 83

From what I can tell you are using FileSearch simply to verify that the file exists.  If that is correct, in place of the With Application.FileSearch ... End With use (the untested)

if dir(folder & application.pathseparator & fname)="" then
  'error about missing file
  exit sub
  end if

 

Hi, Can someone help me with a replacement for this FileSearch, I will really appreciate the help or the ideas, I looked through the posts here they were helpful, but I dont know if they will work fine in my code.

 

The help is highly appreciated

 

'read case number and define output file name

    Windows(bndryfile).Activate

        ActiveCell.Offset(0, 11).Select

        casenum = ActiveCell

        caselength = Len(casenum)

        yft_casenum = "000000"

        yft_casenum = Left(yft_casenum, 6 - caselength) & casenum

        fname = YFT_model & ".033." & yft_casenum

'Open YFT output file

    With Application.FileSearch

        .NewSearch

        .LookIn = folder

        .SearchSubFolders = False

        .Filename = fname

        .MatchTextExactly = True

        .FileType = msoFileTypeAllFiles

        .Execute

        numfiles = .FoundFiles.Count

        If numfiles = 0 Then

            nofile = MsgBox("File: " & fname & " not found!" & Chr(13) & Chr(13) & " -Check cell B5 in BC spreadsheet" & Chr(13) & " -Please try again", vbCritical)

            Exit Sub

        End If

    End With

   

    ChDir (folder)

        Workbooks.OpenText Filename:= _

        folder & "\" & fname, Origin _

        :=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _

        xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False _

        , Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _

        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))

 

---

Tushar Mehta (Technology and Operations Consulting)
www.tushar-mehta.com (Excel and PowerPoint add-ins and tutorials)
Microsoft MVP Excel 2000-Present

Answer 84

Jean Paul ,

I know it has been years but this is an excellent  bit of code and worked perfectly with my application.  Nice job and thanks much

 

Cheers, Martin

---

Cheers, Martin

Answer 85

Hello Everyone,

I used Application.FileSearch then. 

Now I am tying to do it again but unfortunately there is an error prompted stating that With Application.FileSearch'. Could you please modify query and send to me... do you have any alternate query?

Thanks a Lot in advance... 

-------------------

 Sub Batch_Macro()
Dim TbLkn As String
Dim o_wbCurrTempl As Workbook       'Template workbook
Dim o_wsTempl   As Worksheet        'Template worksheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    TbLkn = InputBox("Enter the Path to process")
   
    If TbLkn = "" Then Exit Sub
   
    Set fs = Application.FileSearch

    With fs
        .LookIn = TbLkn
        .SearchSubFolders = True
        .Filename = "*.xls"
       
        If .Execute() > 0 Then
            For i = 1 To .FoundFiles.Count
                Workbooks.Open .FoundFiles(i)
                
                Call Macro1
                
                ActiveWorkbook.SaveAs ActiveWorkbook.FullName, xlNormal
                ActiveWorkbook.Close SaveChanges:=True
            Next i
           
            MsgBox "Processed " & .FoundFiles.Count & " files successfully"
           
        Else
            MsgBox "No files found for processing", vbCritical
        End If
    End With
       
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub 

---------------------

Regards

Karthik

Answer 86

 

I totally agree on this.

Some people here suggest alternatives but these alternastives as far as I know does not give the possibility of doing a search for a specific string inside files(File Content).

Microsoft: Please give us a proper alternative or give us this FileSearch functionality back as soon as possible in an update.

Have a nice day..:-)

 

Answer 87

I've updated to excel 2007 and I'm stuck with no Application.FileSearch :(

Could someone help me with the following code?

 

Sub OperacjeHurtowe()
Dim wbkSkoroszyt As Workbook
Dim i, wiersz As Long
Dim sciezka As String
dato = Range("B3") ' nazwa folderu z  datą do pobrania danych
' określam ścieżkę szukania jako podkatalg dato katalogu gdzie znajduje się skoroszyt Zbiorczy
sciezka = ThisWorkbook.Path & "\" & dato
wiersz = 2 ' zmienna określająca bieżący wiersz w arkuszu gdzie zbieram dane
 
  With Application.FileSearch   ' zaczynam pracę z obiektem FileSearch
        .NewSearch                                ' nowe szukanie
        .LookIn = sciezka                  ' ścieżka poszukiwań
        .SearchSubFolders = False   ' szukanie w podfolderach - nie
        .Filename = "*.xls"              ' nazwa plików
        .FileType = msoFileTypeExcelWorkbooks ' typ pliku - Excel
         
        ' jeżeli liczba znalezionych (i posortowanych przy okazji) jest większa od zero
        If .Execute(msoSortByFileName) > 0 Then
                ' robię pętlę od 1 do liczby znalezionych plików
                For i = 1 To .FoundFiles.Count
                        ' otwieram 1 odnaleziony skoroszyt (a w następnych obiegach pętli  2,3 aż do ilości znalezionych)
                        Set wbkSkoroszyt = Workbooks.Open(.FoundFiles(i))
                        'aktywuję ten skoroszyt
                        wbkSkoroszyt.Activate
                        'Wpisuję nazwę otwartego skoroszytu do arkusza zbiorczego jako nazwę działu (bez 4 końcowych znaków czyli bez .xls)
                        Workbooks("start.xls").Worksheets(2).Range("A" & wiersz) = Mid(wbkSkoroszyt.Name, 1, Len(wbkSkoroszyt.Name) - 4)
                        'przesuwam wiersz o jeden
                        'wiersz = wiersz + 1 '
                        With wbkSkoroszyt.Worksheets(1) ' w pierwszym arkuszu to go skoroszytu
                        'kopiuję zakres A1:B5 do arkusza zbiorczego
                        .Range("K1:L4").Copy Destination:=Workbooks("start.xls").Worksheets(2).Range("B" & wiersz)
                        'zwiększam wiersz o 4 - bo tyle miałem wierszy w kopiowanym zakresie
                        wiersz = wiersz + 4
                        End With ' tyle operacji na tym arkuszu
                        wbkSkoroszyt.Close False 'zamykam odnaleziony skoroszyt bez zapisywania zmian
                Next i ' idź do następnego skoroszytu
        Else ' jeżeli nie znalazlem plików w podanej lokalizacji
                MsgBox "Nie znaleziono zadnych plików" ' daję komunikat
        End If ' koniec możliwości odnoście znajdowania
  End With 'kończę pracę w obiektem FileSearch
 
End Sub

Answer 88

Set a reference to MS Scripting Runtime, and use

Sub OperacjeHurtowe2()
    Dim objFSO As Scripting.FileSystemObject
    Dim objFolder As Scripting.Folder
    Dim colFiles As Scripting.Files
    Dim objfile As Scripting.File
    Dim iFile As Integer

    Dim wbkSkoroszyt As Workbook
    Dim i As Integer
    Dim wiersz As Long
    Dim sciezka As String
    Dim dato As String

    dato = Range("B3").Value    ' nazwa folderu z  data do pobrania danych
    ' okreslam sciezke szukania jako podkatalg dato katalogu gdzie znajduje sie skoroszyt Zbiorczy
    sciezka = ThisWorkbook.Path & "\" & dato
    wiersz = 2    ' zmienna okreslajaca biezacy wiersz w arkuszu gdzie zbieram dane

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(sciezka)
    Set colFiles = objFolder.Files
    iFile = 0
    For Each objfile In colFiles
        If objfile.Type = "Microsoft Excel Worksheet" Then
            '            MergeDocument objfile.Path

            ' jezeli liczba znalezionych (i posortowanych przy okazji) jest wieksza od zero
            ' otwieram 1 odnaleziony skoroszyt (a w nastepnych obiegach petli  2,3 az do ilosci znalezionych)
            Set wbkSkoroszyt = Workbooks.Open(objfile.Path)
            'aktywuje ten skoroszyt
            wbkSkoroszyt.Activate
            'Wpisuje nazwe otwartego skoroszytu do arkusza zbiorczego jako nazwe dzialu (bez 4 koncowych znaków czyli bez .xls)
            Workbooks("start.xls").Worksheets(2).Range("A" & wiersz) = Mid(wbkSkoroszyt.Name, 1, Len(wbkSkoroszyt.Name) - 4)
            'przesuwam wiersz o jeden
            'wiersz = wiersz + 1 '
            With wbkSkoroszyt.Worksheets(1)    ' w pierwszym arkuszu to go skoroszytu
                'kopiuje zakres A1:B5 do arkusza zbiorczego
                .Range("K1:L4").Copy Destination:=Workbooks("start.xls").Worksheets(2).Range("B" & wiersz)
                'zwiekszam wiersz o 4 - bo tyle mialem wierszy w kopiowanym zakresie
                wiersz = wiersz + 4
            End With    ' tyle operacji na tym arkuszu
            wbkSkoroszyt.Close False    'zamykam odnaleziony skoroszyt bez zapisywania zmian
            iFile = iFile + 1
        End If
    Next
    If iFile = 0 Then
        MsgBox "Nie znaleziono zadnych plików"    ' daje komunikat
    End If    ' koniec mozliwosci odnoscie znajdowania

End Sub

---

HTH, Bernie

Answer 89

Almost 4 Years, but I like to thanks you Jean-Paul, your solution work with my case...

Best Regards,
AnuG

---

absetiawan