Solved: Lookin multipe folder

[khalid79m]

            With Application.FileSearch
                .NewSearch
                .LookIn = "\\System\Spreets\" & Range("B1").Value & "\" & Range("C1").Value & "\S\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count

Hi guys help needed this code works fine but I need it to be able to look in 14 differenent locations for example

 
.LookIn = "\\System\Location1\" & Range("B1").Value & "\" & Range("C1").Value & "\S\"
 
then 
 
.LookIn = "\\System\Location2\" & Range("B1").Value & "\" & Range("C1").Value & "\S\"
 
.LookIn = "\\System\Location3\" & Range("B1").Value & "\" & Range("C1").Value & "\S\"

and so on, range("B1") and ("C1") represent the year and month.

Folder tree =


Location 1 is split by 01_2009 then 02_2009 and so on....
same with all the locations

[nst1107]

You may be able to fill an array with the different locations, then put your .FileSearch within a loop and loop through each element of the array.

[khalid79m]

Any tutorials, or futher help ??

[nst1107]

If you post your workbook, or an example, it will be easier to give you more precise help.

[Kenneth Hobs]

This example would open each found xls and put the workbook name into A1 on sheet indexed as 1.

[VBA]Sub BatchRun()
Dim f() As Variant, e As Variant
Dim sRoots() As String, vRoot As String
sRoots() = [{"\\System\Location1\", "\\System\Location2\", "\\System\Location3\"}]
For Each vRoot In sRoots()
f() = FindFiles(vRoot & Range("B1").Value & "\" & Range("C1").Value & "\S\", "*.xls", False)
For Each e In f()
EditWB e
Next e
Next vRoot
End Sub

Sub EditWB(wbName)
Dim wb As Workbook
Set wb = Workbooks.Open(wbName)
wb.Worksheets(1).Range("A1").Value = wb.Name
wb.Close True
End Sub

Function FindFiles(sRootFolder As String, sFiles As String, _
Optional searchSubFolders As Boolean = True) As Variant

Dim fs As Object
Dim strFilename As String
Dim i As Long, LastRow As Long
Dim a() As Variant

Set fs = Application.FileSearch
With fs
.LookIn = sRootFolder
.Filename = sFiles 'set your filename or extension with wilcards if needed.
.searchSubFolders = searchSubFolders
LastRow = .FoundFiles.Count
If .Execute() > 0 Then
For i = 1 To LastRow
strFilename = .FoundFiles(i)
ReDim Preserve a(i - 1)
a(i - 1) = strFilename
Next i
Else
MsgBox "No " & sFiles & " in " & sRootFolder & " found!", vbCritical
End
End If
End With

FindFiles = a()

End Function
[/VBA]

[khalid79m]

Private Sub Site_Calls_Run_A()
    Windows("Control.xls").Activate
    Sheets("SITE").Select
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    With Range("A3:IV65536")
        .ClearContents
    End With
Application.ScreenUpdating = False
Application.EnableEvents = False
    
            Dim i As Integer, wb As Workbook
            
'SITE1
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE1\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE2
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE2\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE3
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\Global\SITE3\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE4
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\Global\SITE4\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE5
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE5\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE6
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE6\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE7
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE7\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE8
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE8\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE9
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE9\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
'SITE10
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE10\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE11
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE11\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
'SITE12
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE12\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE13
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE13\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
'SITE14
            With Application.FileSearch
                .NewSearch
                .LookIn = "\\Easy\One\Print\UK\SITE14\" & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
                .SearchSubFolders = True
                .Filename = "*.xls"
                .Application.DisplayAlerts = False
                .Execute
            For i = 1 To .FoundFiles.Count
                Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
            Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
                Run "Site_Calls_Run_A1"
                wb.Close savechanges:=False
            Next i
            End With
            
Application.EnableEvents = True
Application.ScreenUpdating = True
         
    
End Sub
Private Sub Site_Calls_Run_A1()
Application.StatusBar = "RETRIEVE | " & Now() & " | " & ActiveWorkbook.Name
    Sheets("Submitted_Calls").Select
    
If Range("A3") <> "" Then
  
        Dim Lastrow As Long
        Application.ScreenUpdating = False
        Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
  
    With Range("A3:IV" & Lastrow)
        .Copy
    End With
    Windows("Control.xls").Activate
    
    Sheets("SITE").Select
    Range("A65536").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
End If
End Sub

Hi Kennith , this is my currrent code, as you can see in Private Sub Site_Calls_Run_A() a block of code is repeated 14 times is there anyway to improve this

(Please look at site 3 and 4 they have global instead of uk)

Can anyone help >?

[Kenneth Hobs]

You would just adapt what I posted earlier to something like that below. I added a link to my kb entry for speed routines. You can use them or just use parts as you did.
[VBA]Private Sub Site_Calls_Run_A()
Dim i As Integer, wb As Workbook
Dim sLook() As String, vLook As Variant

On Error GoTo EndSpeed
'http://vbaexpress.com/kb/getarticle.php?kb_id=1035
SpeedOn

Windows("Control.xls").Activate
Sheets("SITE").Select
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
Range("A3:IV65536").ClearContents

ReDim sLook(1 To 6) As String
sLook(1) = "\\Easy\One\Print\UK\SITE1\"
sLook(2) = "\\Easy\One\Print\UK\SITE2\"
sLook(3) = "\\Easy\One\Print\UK\SITE3\"
sLook(4) = "\\Easy\One\Print\UK\SITE4\"
sLook(5) = "\\Easy\One\Print\UK\SITE5\"
sLook(6) = "\\Easy\One\Print\UK\SITE6\"

For Each vLook In sLook()
'SITEs
With Application.FileSearch
.NewSearch
.LookIn = vLook & Range("B1").Value & "\" & Range("C1").Value & "\SET\"
.SearchSubFolders = True
.Filename = "*.xls"
.Application.DisplayAlerts = False
.Execute
For i = 1 To .FoundFiles.Count
Application.StatusBar = "OPEN | " & Now() & " | " & ActiveWorkbook.Name
Set wb = Workbooks.Open(Filename:=.FoundFiles(i), ReadOnly:=True)
Run "Site_Calls_Run_A1"
wb.Close savechanges:=False
Next i
End With
Next vLook

EndSpeed:
SpeedOff
End Sub[/VBA]

[khalid79m]

Thanks Kenneth, that worked a treat, sorry for the delay in responding to you been off ill.. hope you had a good christmas and new year.

I have one further question if you can assist

Private Sub FileNamesSITE()
Application.DisplayAlerts = False
    Workbooks("Control.xls").Sheets.Add.Name = "Shared_Drive"
    Workbooks("Control.xls").Sheets("Shared_Drive").Range("A1").Select
        
Application.DisplayAlerts = True
        
    Set oFSO = CreateObject("Scripting.FileSystemObject")
     
    SelectFiles "\\Folder1\Folder1a\Folder1c\"
     
    Set oFSO = Nothing
     
End Sub

Private Sub SelectFiles(sPath)
     
    Dim Folder As Object
    Dim Files As Object
    Dim file As Object
    Dim fldr
     
    Set Folder = oFSO.GetFolder(sPath)
     
    For Each fldr In Folder.SubFolders
        SelectFiles fldr.Path
    Next fldr
     
    For Each file In Folder.Files
         
        If file.Type Like "*Microsoft Excel*" Then
             
            NextRow = NextRow + 1
            'ActiveSheet.Cells(NextRow, "A").Value = file.Path
            ActiveSheet.Cells(NextRow, "A").Value = file.Name
        End If
    Next file
    
End Sub

I need this to be able to do what you did for me in the previous query above. Can this be done, I dont understand the code well enought to write it myself.

[Kenneth Hobs]

Maybe:
[vba]Option Explicit
Private Sub FileNamesSITE()
Dim sLook() As String, vLook As Variant

Application.DisplayAlerts = False
Workbooks("Control.xls").Sheets.Add.Name = "Shared_Drive"

Application.DisplayAlerts = True

ReDim sLook(1 To 6) As String
sLook(1) = "\\Folder1\Folder1a\Folder1c\"
sLook(2) = "\\Easy\One\Print\UK\SITE2\"
sLook(3) = "\\Easy\One\Print\UK\SITE3\"
sLook(4) = "\\Easy\One\Print\UK\SITE4\"
sLook(5) = "\\Easy\One\Print\UK\SITE5\"
sLook(6) = "\\Easy\One\Print\UK\SITE6\"

For Each vLook In sLook()
SelectFiles vLook
Next vLook

Application.DisplayAlerts = True
End Sub

Private Sub SelectFiles(sPath)
Dim Folder As Object
Dim Files As Object
Dim file As Object
Dim fldr
Dim oFSO As Object
Dim NextRow As Long

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder(sPath)

For Each fldr In Folder.SubFolders
SelectFiles fldr.Path
Next fldr

For Each file In Folder.Files
If file.Type Like "*Microsoft Excel*" Then
NextRow = NextRow + 1
'ActiveSheet.Cells(NextRow, "A").Value = file.Path
ActiveSheet.Cells(NextRow, "A").Value = file.Name
End If
Next file

Set oFSO = Nothing
End Sub
[/vba]

[khalid79m]

Hi kenneth this seems good just 1 problem I need to add in the range values as in the original query

[Kenneth Hobs]

Whether the path string is "c:\" or something more elaborate, the concept is the same.

e.g.
[vba]sLook(1) = "\\Folder1\Folder1a\Folder1c\" & Range("B1").Value & "\" & Range("C1").Value & "\S\"
[/vba]

[khalid79m]

Hi this works like a treat only one thing it over copys the data in cell a1 ,

so it does the first location, fine, then second location it starts pasting the file names from a1 downwards hence over typing the fil names from location 1..

How can I fix this?

Thanks for all you help, your great...

[Kenneth Hobs]

Replace:
[vba]ActiveSheet.Cells(NextRow, "A").Value = file.Name[/vba]
With:
[vba]Range("A" & rows.Count).End(xlUp).Offset(1,0).Value =file.Name[/vba]

You might need an If to check that
[vba]Range("A" & rows.Count).End(xlUp).Offset(1,0).Row[/vba]
is not equal to 1 so that A1 gets filed. Most have a Column label in A1 so it is not a problem for them.

[khalid79m]

Hi Kenneth,

Your code was prefect, I just didnt explain my requirements properly. I have broken down your code and fully understand each step and have changed the code to refelct my requirements.

I just wanted to say thanks for all the support I really appreciated it and been a good learning process for me.

Thanks

[khalid79m]

Hi Kenneth,

Your code was prefect, I just didnt explain my requirements properly. I have broken down your code and fully understand each step and have changed the code to refelct my requirements.

I just wanted to say thanks for all the support I really appreciated it and been a good learning process for me.

Thanks