PDA

View Full Version : Formula based on files in directory



SJ McAbney
09-07-2004, 02:53 AM
I have a spreadsheet that collects information from a number of different spreadsheets in the same directory.

It's one of those where one person has their own spreadsheet, another has theirs, etc. There is also a summary sheet that adds up the values over the different spreadsheets. Each sheet - including the summary has the same layout.

The problem is that as people come and go their will need to be a different spreadsheet for each person detailing their workloads. I could manually change the summary spreadsheet's formulae but this is too time consuming and I don't, to be honest, trust those who'll be using it going forward to do this on their own.

I've tried and played about with this code:

Sub Button1_Click()
Const strExtension As String = "\*.xls"
Const bytMonth = 1
Dim strFileList() As String
Dim rng As Range, strTemp As String
Dim strFileName As String
Dim strPathName As String
Dim intIndex As Integer

strPathName = ActiveWorkbook.Path

strFileName = Dir(strPathName & strExtension)
While strFileName <> vbNullString
ReDim Preserve strFileList(0 To intIndex)
If Not strFileName Like "Summary*" Then
strFileList(intIndex) = strFileName
End If
strFileName = Dir()
intIndex = intIndex + 1
Wend
If intIndex = 0 Then
MsgBox "No files found"
Exit Sub
End If

Range("D8:N38").Select
For Each rng In Selection
strTemp = vbNullString
For intIndex = 1 To UBound(strFileList)
If Not strFileList(intIndex) = vbNullString Then
strTemp = strTemp & "'" & ActiveWorkbook.Path & "[" & strFileList(intIndex) & "]" & MonthName(bytMonth) & "'!" & rng.Address & ","
End If
Next intIndex
strTemp = "=SUM(" & Left(strTemp, Len(strTemp) - 1) & ")"
rng.Formula = strTemp
Next
End Sub

The idea is that each cell within the range would provide a SUM formula or value (if need be).

CBrine
09-07-2004, 10:01 AM
This code will cycle through and entire list of files that meet the *.xls criteria within the specified folder. You should be able to drop your formatting code into the area indicated.

Private Sub CommandButton1_Click()
Dim ws As Worksheet, Path As String

Path = "C:\temp\"
Set ws = ActiveSheet

Filename = Dir(Path & "*.xls")

Do Until Filename = ""

Workbooks.Open Path & Filename


Your code here

Filename = Dir
Loop

End Sub