Total the value from unopened workboks in an open workbook

Hi Nils
Is the cell in the same sheet on all workbooks ?
and is this sheet name always the same ?
If it is then perhaps I can help.

Ivan

The sheet name is the same and the data is in the same location in all the files and all the files are grouped in one folder on the network.

Hi Nils

Try this;

cut & paste to a Std module of a new workbook
attache the macro to an object
The value will be placed in cell A1.

NB: change the cell ref @ CWRIR Drive, usDirFiles(WB), "Sheet1", "R1C1" '<CHANGE THE CELL ADDRESS HERE!>

Note in R1C1 reference style!

Let me know if OK, would suggest you check it
on a test Dir of Known values for the integrety
of your data.

Ivan

'==========================================================================================
'= =
'= Module: Misc =
'= Type: Standard Module =
'= =
'= Developer: Modified by Ivan F Moala =
'= Date: 10-May-2000 =
'= =
'= Description: Get Rangevalue from all xls files in a user selected Directory. =
'= My Thanks to David Hager & John Walkenback =
'= =
'= Subprocedures: GetSum - Gets the sum of a range in an array of xls in UD Dir =
'= CWRIR - ClosedWorkbookIntoRange (Amended) =
'= Functions: GetDirectory - Gets user selected Dir (Orig) =
'= Properties: None =
'= DLL Declares: SHGetPathFromIdList - Alias SHGetPathFromIDListA =
'= SHBrowseForFolder - Alias SHBrowseForFolderA =
'= =
'==========================================================================================
Option Explicit
Dim fpStr As String
Dim Ans
Dim CWA
Dim i As Integer
Dim Drive As String
Dim filename As Variant 'Must be a variant !!
Dim usDirFiles() As String 'UserSelectedDirectory Files
Dim FFiles As Integer
Dim WB As Integer
Dim Q As Integer
Dim NoSheet1Found As Integer
Dim SumOfAllWorkbooks As Double

Public Type BROWSEINFO
hOwner As Long
pid1Root As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Declare Function SHGetPathFromIdList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pid1 As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Root folder = desktop
bInfo.pid1Root = 0&

'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Select a folder"
Else
bInfo.lpszTitle = msg
End If

'Type of Dir to return
bInfo.ulFlags = &H1

'Display the dialog
x = SHBrowseForFolder(bInfo)

'Parse the result
path = Space$(512)
r = SHGetPathFromIdList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub GetValuesRg_ClosedWkBook()

'---------------------
SelectAgain:
Drive = GetDirectory("Select the directory of the files to get the value from:")
If Drive = "" Then End
Ans = MsgBox(Drive, vbInformation + vbYesNo, "Get all xls files in this Directory?")
If Ans = vbNo Then GoTo SelectAgain
'----------------------

With Application.FileSearch
.NewSearch
.LookIn = Drive
.SearchSubFolders = False
.filename = "*.xls"
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
ReDim usDirFiles(.FoundFiles.Count)
For i = 1 To .FoundFiles.Count
usDirFiles(i) = Application.WorksheetFunction.Substitute(.FoundFiles(i), Drive, "", 1)
usDirFiles(i) = Right(usDirFiles(i), Len(usDirFiles(i)) - 1)
Next
End If
If .FoundFiles.Count = 0 Then
Q = MsgBox("No xls files in " & Drive & Chr(13) & Chr(13) & _
"Select another Dir?", vbExclamation + vbYesNo, "Search Result")
If Q = vbYes Then GoTo SelectAgain
End
End If
End With

On Error GoTo ErrH
'First Resetsettings incase of multiple runs
ActiveSheet.Range("A1").Activate
Range("A1") = 0
SumOfAllWorkbooks = 0
NoSheet1Found = 0
'Now process array
For WB = 1 To UBound(usDirFiles())
CWRIR Drive, usDirFiles(WB), "Sheet1", "R1C1" '<CHANGE THE CELL ADDRESS HERE!>
Range("A1") = ExecuteExcel4Macro(fpStr)
SumOfAllWorkbooks = SumOfAllWorkbooks + Range("A1")
Next

Range("A1") = SumOfAllWorkbooks

MsgBox "Completed updating sum of: " & Drive & _
Chr(13) & Chr(13) & WB - 1 & " Files were accessed " & Chr(13) & _
"Missed Files due to [Sheet1] not found and/or Text found:=" & NoSheet1Found, vbInformation

Exit Sub

ErrH:
'Errors appplicable to this routine
'1004 indicates ref# ErrorFormula 13 = RefInvalid
If Err.Number = 13 Or Err.Number = 1004 Then
NoSheet1Found = NoSheet1Found + 1
Resume Next
Else
MsgBox Err.Number & " :=" & Err.Description
Resume Next
End If
End Sub

'CWRIR is short for ClosedWorkbookRangeIntoArray
Sub CWRIR(fPath As String, Fname As String, sName As String, _
rng As String)

On Error GoTo NoDir
If Right(fPath, 1) <> "\" Then fPath = fPath & "\"
If Dir(fPath & Fname) = "" Then
CWA = CVErr(xlErrValue)
Exit Sub
End If

fpStr = "'" & fPath & "[" & Fname & "]" & sName & "'!" & rng

NoDir:
End Sub