PDA

View Full Version : Solved: Lookin multipe folder



khalid79m
12-23-2008, 08:49 AM
With Application.FileSearch
.NewSearch
.LookIn = "\\ (file://Gb000abc0001/Employee)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\ (file://\\System\Location1\)" & Range("B1").Value & "\" & Range("C1").Value & "\S\"

then

.LookIn = "\\System\Location2\ (file://\\System\Location2\)" & Range("B1").Value & "\" & Range("C1").Value & "\S\"

.LookIn = "\\System\Location3\ (file://\\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: pray2:

nst1107
12-23-2008, 09:03 AM
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
12-23-2008, 09:14 AM
Any tutorials, or futher help ??

nst1107
12-23-2008, 09:34 AM
If you post your workbook, or an example, it will be easier to give you more precise help.

Kenneth Hobs
12-23-2008, 09:37 AM
This example would open each found xls and put the workbook name into A1 on sheet indexed as 1.

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

khalid79m
12-23-2008, 10:26 AM
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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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\ (file://\\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
12-23-2008, 12:30 PM
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.
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

khalid79m
01-02-2009, 05:44 AM
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\ (file://\\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
01-02-2009, 07:10 AM
Maybe:
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\ (file://\\Folder1\Folder1a\Folder1c\)"
sLook(2) = "\\Easy\One\Print\UK\SITE2\ (file://\\Easy\One\Print\UK\SITE2\)"
sLook(3) = "\\Easy\One\Print\UK\SITE3\ (file://\\Easy\One\Print\UK\SITE3\)"
sLook(4) = "\\Easy\One\Print\UK\SITE4\ (file://\\Easy\One\Print\UK\SITE4\)"
sLook(5) = "\\Easy\One\Print\UK\SITE5\ (file://\\Easy\One\Print\UK\SITE5\)"
sLook(6) = "\\Easy\One\Print\UK\SITE6\ (file://\\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

khalid79m
01-02-2009, 08:31 AM
Hi kenneth this seems good just 1 problem I need to add in the range values as in the original query

Kenneth Hobs
01-02-2009, 08:37 AM
Whether the path string is "c:\" or something more elaborate, the concept is the same.

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

khalid79m
01-02-2009, 09:22 AM
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...: pray2:

Kenneth Hobs
01-02-2009, 09:41 AM
Replace:
ActiveSheet.Cells(NextRow, "A").Value = file.Name
With:
Range("A" & rows.Count).End(xlUp).Offset(1,0).Value =file.Name

You might need an If to check that
Range("A" & rows.Count).End(xlUp).Offset(1,0).Row
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
01-08-2009, 03:17 AM
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 :bow:

khalid79m
01-08-2009, 03:17 AM
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 :bow: