Query Folder for Spreadsheets  
Author Message
Wunmaan





PostPosted: Wed Mar 14 00:03:03 CDT 2007 Top

Excel Programming >> Query Folder for Spreadsheets

I have multiple spreadsheet files, all with the same information, all
formatted the same, etc. from a template I set up.

I want to have another "new" spreadsheet that I can use to total up some key
fields from each spreadsheet. But I don't want to manually enter the file
name/path each time as each year progresses or something changes in the file
name/location.

Can it be programmed to query all files in the folder of this "new"
spreadsheet is located in, with the exception of the total "new" spreadsheet
file, to capture the file names, then I can simply add the sheet/cell
reference I need to capture to sum the data?

This will hopefully save me from having to open each file up and manually
summing up fields or maintaining a bunch of file names.

Any help is appreciated.

Excel394  
 
 
OssieMac





PostPosted: Wed Mar 14 00:03:03 CDT 2007 Top

Excel Programming >> Query Folder for Spreadsheets This might help. The basis of this procedure was from a posting on the forum
yesterday. It obtains all workbooks in the current folder and any subfolders
and lists all the workbooknames and worksheet names within the workbooks and
records them on a spreadsheet in 2 columns. See if it gives you enough info
to base your required procedure. (If you only want the current folder then
ensure you change searchsubfolders to false)

Dim i As Integer 'Used in loop.
Dim j As Integer 'Used for row identifier when writing data.
Dim wbResults As Workbook 'Name of workbook found
Dim wbCodeBook As Workbook 'Holds name of this workbook
Dim currentFile As String 'Id of current file with full path
Dim wSheet As Worksheet 'Worksheet in found workbook
Dim myCurrentPath As String 'Current path of this workbook
Dim myCurrentPathLgth As Integer 'Length of path string used in Mid()
function

Sub GetAllWorksheetNames()

'This macro designed to run from the folder where it has to _
search for the files and subfolders.
Sheets("Sheet1").Select

Cells.Select
Selection.Clear

'Insert column titles
Range("A1") = "Work Book Name"
Range("B1") = "Work Sheet Name"
Range("A1:B1").Font.Bold = True
Range("A1").Select

Application.DisplayAlerts = False
Application.EnableEvents = False

myCurrentPath = CurDir
currentFile = myCurrentPath & "\" & ActiveWorkbook.Name

'Plus 2 allows backslash plus 1 for next
'start character in the mid()function below
myCurrentPathLgth = Len(myCurrentPath) + 2

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = myCurrentPath
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then '> 0 Then files of required type exist
j = 1 'Row numbers. Initialize as 1 to allow for column headers
For i = 1 To .FoundFiles.Count
'Test that not current file in use.
If LCase(.FoundFiles(i)) <> LCase(currentFile) Then
Set wbResults = Workbooks.Open(.FoundFiles(i))
For Each wSheet In wbResults.Worksheets
j = j + 1 'Sets row number
wbCodeBook.Sheets(1).Cells(j, 1) _
= Mid(.FoundFiles(i), myCurrentPathLgth)
wbCodeBook.Sheets(1).Cells(j, 2) = Format(wSheet.Name)
Next wSheet
wbResults.Close SaveChanges:=False
End If
Next i
End If
End With

Sheets("Sheet1").Select
Columns("A:B").Select
Selection.Columns.AutoFit
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.CalculateFull

End Sub