HELP: Link all values in a workbook under same folder on one sheet

M

m

Hi there!

Am doing a consolidation macro that will require me to
sum all values in a specific cell (e.g. A1), under same
worksheet (e.g Sheet1) of all the workbooks (of
indefinite number) found under one folder.

Can anyone provide me a sample script can use? Tnx a
bunch! =)
 
F

Fred

Hi !

You can try the following code to:
- loop through a folder
- Open all .xls files
- Loop through the sheets
- Save and close the workbook



Sub LoopFolder()

Dim FileName As String
Dim FindDirectory As String

FindDirectory = "C:\Temp\" 'Put your foldername here

FileName = Dir(FindDirectory, vbNormal)
Do While FileName <> ""
If Right(FileName, 4) = ".xls" Then
Workbooks.Open FileName:=FindDirectory & FileName
'Do whatever you have to do withe the workbook, for example:
For Each sh In ActiveWorkbook.Sheets
Debug.Print FileName & " - " & sh.Name
Next sh
ActiveWorkbook.Close savechanges:=True
End If
FileName = Dir
Loop

End Sub
 
P

papou

Hello m
Here's a try (amend sheet name and path)
(please note that workbook containing code should NOT be in same directory
as files searched)
Option Base 1
Sub Consolider()
With Application.FileSearch
..NewSearch
..LookIn = "C:\DOC\Robi10\Doc\Excel\Tests\MPFE"
..FileType = msoFileTypeExcelWorkbooks
If .Execute() <> 0 Then
Dim Part1, Part2, SourceFile$, n&, AntiSlashPos&, FileNamesArray()
For i = 1 To .FoundFiles.Count
'Define array bounds
ReDim Preserve FileNamesArray(1 To .FoundFiles.Count)
'Now build the correct syntax to consolidate:
n = Len(.FoundFiles(i)) - Len(Replace(.FoundFiles(i), "\", ""))
AntiSlashPos = Position(.FoundFiles(i), n)
'Part1 = full path
Part1 = Mid(.FoundFiles(i), 1, AntiSlashPos)
'Part2 = filename only
Part2 = Mid(.FoundFiles(i), AntiSlashPos + 1, Len(.FoundFiles(i)) -
AntiSlashPos)
SourceFile = "'" & Part1 & "[" & Part2 & "]Feuil1'!R1c1"
FileNamesArray(i) = SourceFile
'End If
Next i
ThisWorkbook.Sheets("Feuil1").Range("A1").Consolidate Sources:= _
Array(FileNamesArray()), Function:=xlSum, _
TopRow:=False, LeftColumn:=False, CreateLinks:=True
End If
End With
End Sub
'returns position of Antislash from a path info
Function Position(Chemin$, Nb&) As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim i As Long
Pos2 = 0
For i = 1 To Nb
Pos1 = Pos2
Pos2 = InStr(Pos1 + 1, Chemin, "\")
If Pos2 = 0 Then Exit For
Next i
If Pos2 > Pos1 Then
Position = Pos2
Else
Position = 0
End If
End Function

HTH
Cordially
Pascal
 
Top