Chilidog-
Here is code (modified to remove proprietary info like paths, etc) that I
wrote to open every single Excel file on a specific sharepoint site to
retrieve data into a consolidated workbook (I'll delete the data part, since
your question is about access). I believe that this version was after I had
to update it to also work on Excel 2007. I hope this helps! Since I'm
deleting large chunks of code, beware as I'm probably not matching up all the
if/endif and for/next loops (I might delete one end but not the other). I
don't take credit for the code, it was hobbled together from information from
this newsgroup and google searches (but it works!)
Keith
Option Explicit
Global asd 'variant 1-D array
Sub SrchForFiles()
' Searches the selected folders and sub folders for files with the
specified (xls) extension.
' Data pushed to worksheet called "FileSearch Results".
'! now integrated directly into this sub
'ListTheFiles 'get the list of all the target XLS files on the
sharepoint directory
Dim i As Long, z As Long, Rw As Long, ii As Long
Dim ws As Worksheet, dd As Worksheet
Dim y As Variant
Dim fldr As String, fil As String, FPath As String
Dim LocName As String
Dim FString As String
Dim SummaryWB As Workbook
Dim SummaryWS As Worksheet
Dim Raw_WS As Worksheet
Dim LastRow As Long, FirstRow As Long, RowsOfData As Long
Dim UseData As Boolean
Dim FirstBlankRow As Long
'grab current location for later reference, for where to paste final data
Set SummaryWB = Application.ActiveWorkbook
Set SummaryWS = Application.ActiveWorkbook.ActiveSheet
y = "xls"
fldr = "\\share.companyname.com\departmentname\foldername\"
FirstBlankRow = 2
'Application.ScreenUpdating = False
'asd is a 1-D array of files returned
asd = ListFiles(fldr, True)
Set dd = Excel.ThisWorkbook.Worksheets(3) 'destination for data
Set ws = Excel.ThisWorkbook.Worksheets(1) 'list of files
dd.Activate
dd.Range("A1:AZ1000").Clear
ws.Activate
ws.Range("A1:Z100").Select
Selection.Clear
On Error GoTo 0
For ii = LBound(asd) To UBound(asd)
Debug.Print Dir(asd(ii))
fil = asd(ii)
'screen for target file names ("Multi*.xls")
If UCase(Left(Dir(fil), 5)) = "MULTI" Then
'open the file and grab the data
Application.Workbooks.Open (fil), False, True
End If
'Get file path from file name
FPath = Left(fil, Len(fil) - Len(Split(fil,
"\")(UBound(Split(fil, "\")))) - 1)
'Get file information
If Left$(fil, 1) = Left$(fldr, 1) Then
If CBool(Len(Dir(fil))) Then
z = z + 1
ws.Cells(z + 1, 1).Resize(, 6) = _
Array(Dir(fil), LocName, RowsOfData,
Round((FileLen(fil) / 1000), 0), FileDateTime(fil), FPath)
DoEvents
End If
End If
Application.CutCopyMode = False 'Clear Clipboard
Workbooks(Dir(fil)).Close SaveChanges:=False
End If
End If
Next ii
End With
End Sub
' list all the files in a directory
' if NESTEDDIRS = True it lists a whole directory tree
' returns a 1-based array containing all the listed files
Function ListFiles(ByVal Path As String, Optional ByVal NestedDirs As
Boolean) _
As String()
Dim fso As New Scripting.FileSystemObject
Dim fld As Scripting.Folder
Dim fileList As String
' get the starting folder
Set fld = fso.GetFolder(Path)
' let the private subroutine do all the work
fileList = ListFilesPriv(fld, NestedDirs)
' (the first element will be a null string unless the first ";" is
removed)
fileList = Right(fileList, Len(fileList) - 1)
' convert to a string array
ListFiles = Split(fileList, ";")
End Function
' private procedure that returns a file list
' as a comma-delimited list of files
Function ListFilesPriv(ByVal fld As Scripting.Folder, _
ByVal NestedDirs As Boolean) As String
Dim fil As Scripting.File
Dim subfld As Scripting.Folder
' list all the files in this directory
For Each fil In fld.Files
If fil.Type = "Microsoft Excel Worksheet" Then
ListFilesPriv = ListFilesPriv & ";" & fil.Path
Debug.Print fil.Path
End If
Next
' if requested, search also subdirectories
If NestedDirs Then
For Each subfld In fld.SubFolders
ListFilesPriv = ListFilesPriv & ListFilesPriv(subfld, NestedDirs)
Next
End If
End Function
