Cell - Read - Closed Files!

From closed Workbooks certain cells are selected and summed up. The cells which can be selected are indicated in Sheet2 in column A. Some lines in the code must be adapted. These are characterized. In the ZIP file are example files. It functions immediately, if the file with the code is in the same folder as the files with the cells which must be read in. Subfolders are considered. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Option Private Module
Const strSheet As String = "Sheet1" 'adapt
Public Sub Files_Read()
Dim stCalc As XlCalculation
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path 'adapt
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, _
ByVal strName As String)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim varRange As Variant
Dim varTMP As Variant
Dim intTMP As Integer
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> _
ThisWorkbook.Name Then
With Sheet2 'adapt
varRange = .Range(.Cells(1, 1), .Cells _
(.Rows.Count, 1).End(xlUp).Rows)
strFormula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev _
(varTMP.Path, "\") + 1) & "]" & strSheet & "'!"
For intTMP = 1 To Ubound(varRange)
.Range("B" & intTMP).Formula = _
strFormula & varRange(intTMP, 1)
Sheet1.Range(varRange(intTMP, 1)).Value = _
Sheet1.Range(varRange(intTMP, 1)).Value + _
.Range("B" & intTMP).Value
Next intTMP
End With
End If
Next
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
Set objWorkbook = Nothing
End Sub


Sample ZIP - 2007 and 2003

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...