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:
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.