PDA

View Full Version : Excel 2007 file search



khalid79m
01-10-2010, 06:25 AM
Sub A()
Dim I As Integer, wb As Workbook
Dim sLook() As String, vLook As Variant

ReDim sLook(1 To 1) As String 'change the slook to suit the number of different locations
sLook(1) = "C:\Users\nn\Documents\Historic_Data\34SCA\"

For Each vLook In sLook()
With Application.FileSearch ' code fails here
.NewSearch
.LookIn = vLook
.SearchSubFolders = True
.Filename = "*.xls"
.Application.DisplayAlerts = False
.Execute
For I = 1 To .FoundFiles.Count
MsgBox vLook
'Set wb = Workbooks.Open(Filename:=.FoundFiles(I), ReadOnly:=True)
'wb.Close Savechanges:=False
Next I
End With
Next vLook

End Sub

this a snippet of code i have , our systems have gone from 2003 to 2007 and the filesearch function doesnt work :( can anyone amend this code, i have no idea on how to do it

xld
01-10-2010, 06:36 AM
Sub A()
Dim wb As Workbook
Dim sLook() As String, vLook As Variant
Dim fName As String

ReDim sLook(1 To 2) As String 'change the slook to suit the number of different locations
sLook(1) = "C:\Users\nn\Documents\Historic_Data\34SCA\"
sLook(2) = "C:\test\"

For Each vLook In sLook

fName = Dir(vLook & "*.xls")
Do While fName <> ""

MsgBox fName
'Set wb = Workbooks.Open(Filename:=vlook & fname, ReadOnly:=True)
'wb.Close Savechanges:=False

fName = Dir
Loop
Next vLook

End Sub

khalid79m
01-10-2010, 06:39 AM
will this cover subfolders ?

khalid79m
01-10-2010, 07:16 AM
:dunno :dunno I need the code to be able to search sub folders.

can anyone help

xld
01-10-2010, 07:57 AM
Sub A()
Dim FSO As Object
Dim wb As Workbook
Dim sLook() As String, vLook As Variant
Dim fName As String

ReDim sLook(1 To 2) As String 'change the slook to suit the number of different locations
sLook(1) = "C:\Users\nn\Documents\Historic_Data\34SCA\"
sLook(2) = "C:\test\"

Set FSO = CreateObject("Scripting.FilesystemObject")

For Each vLook In sLook

Call ProcessFolder(FSO, CStr(vLook))
Next vLook

End Sub

Private Function ProcessFolder(FSO As Object, FolderName As String)
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object

On Error Resume Next
Set Folder = FSO.getfolder(FolderName)
On Error GoTo 0
If Not Folder Is Nothing Then

For Each File In Folder.Files

If File.Type Like "*Office Excel*" Then

MsgBox File.Name
'Set wb = Workbooks.Open(Filename:=vlook & fname, ReadOnly:=True)
'wb.Close Savechanges:=False
End If
Next File

For Each SubFolder In Folder.SubFolders

Call ProcessFolder(FSO, FolderName & SubFolder.Name & "\")
Next SubFolder
End If

Set Folder = Nothing
Set SubFolder = Nothing
End Function

khalid79m
01-10-2010, 08:52 AM
Sorry XLD I have written this code before you put your respons on , it is quite similar

I need help though, I would like make to make some tweeks, i have marked them on the code


Private Sub FileNamesSET()
Dim sLook() As String, vLook As Variant

ReDim sLook(1 To 1) As String
sLook(1) = "C:\Users\MK\Documents\Historic_Data\"

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 Lastrow1 As Long
Dim Source As String
Dim Destination As String


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
Workbooks.Open (file), , True
Source = file.Name

' how do I set the sheet name to the file.name but exlude the .xls so if the file was called Easy.xls then sheet would be Easy
Lastrow1 = Workbooks(Source).Sheets().Cells(Cells.Rows.Count, "A").End(xlUp).Row
Workbooks(Source).Sheets().Range("A2:D" & Lastrow1).Copy

' how do I set the sheet name to the 2 folder up for example
'C:\Users\MK\Documents\Historic_Data\
'C:\Users\MK\Documents\Historic_Data\34SCA
'C:\Users\MK\Documents\Historic_Data\34SCA\2008
'C:\Users\MK\Documents\Historic_Data\34SCA\2009
'SO the destination sheet name would be 34SCA


Lastrow1 = Workbooks(Destination).Sheets().Cells(Cells.Rows.Count, "A").End(xlUp).Row
Workbooks(Destination).Sheets().Range("A2" & Lastrow1 + 1).pastespecial



'Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = file.Name
Next file

Set oFSO = Nothing
End Sub

khalid79m
01-10-2010, 09:58 AM
Hi can anyone help

i need to trim this

Source_Wkb = File.Name (this correct)
Source_Wkst = File.Name (I need to trim the .xls off this)

the file.name is test.xls

xld
01-10-2010, 11:06 AM
Replace(File.Name,".xls","")