Geschlossene Dateien - Range und Summe bestimmter Zellen...

' Variablendeklaration erforderlich
OptionExplicit
' Der Tabellenblattname in den auszulesenden Dateien
ConststrSheetQAsString="Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
ConststrSheetZAsString="Werte"
' Diese Zellen werden Summiert
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
PublicSubMain()
' Variablendeklaration
DimblnUpdateAsBoolean
DimobjShellAsObject
DimintCalcAsInteger
DimstrDirAsString
DimobjFSOAsObject
DimobjDirAsObject
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
.ScreenUpdating=False
blnUpdate=.AskToUpdateLinks
.AskToUpdateLinks=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
SetobjFSO=CreateObject("Scripting.FileSystemObject")
' Wenn Du einen Ordnerauswahldialog möchtest
'Set objShell = CreateObject("Shell.Application")
'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
'strDir = varDir.Self.Path
' Datei im gleichen Ordner wie Auswertungsdateien
strDir=ThisWorkbook.Path
'strDir = "C:\Temp\Los\"  ' Fester Pfad
SetobjDir=objFSO.GetFolder(strDir)
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier strSheetZ
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithThisWorkbook.Worksheets(strSheetZ)
' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
.Rows("2:"&.Rows.Count).ClearContents
' Mit Unterordner
dirInfoobjDir,"*.xls*",True
' Ohne Unterordner
'dirInfo objDir, "*.xls*"
' Formeln entfernen - Werte bleiben erhalten
.UsedRange.Value=.UsedRange.Value
EndWith
Fin:
' Setze die Objektvariablen auf Nothing
SetobjDir=Nothing
SetobjFSO=Nothing
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=blnUpdate
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
' Rekursive Sub mit Array - Optional mit Unterordner
PublicSubdirInfo(ByValobjCurrentDirAsObject,ByValstrNameAsString,_
OptionalByValblnTMPAsBoolean=False)
' Variablendeklaration
DimstrFormulaAsString
DimlngLastRowAsLong
DimarrCellAsVariant
DimintTMPAsInteger
DimvarTMPAsVariant
' Weitere Zellen nach gleichem Muster in das Array einfügen
arrCell=Array("A1","C1","E2","H8","I8",_
"H16","I16","H24","I24","H32","I32","C8",_
"D8","C16","D16","C24","D24","C32","D32")
' Alle Dateien im vorgegebenen Ordner
ForEachvarTMPInobjCurrentDir.Files
' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
' Falls im gleichen Ordner und ist KEINE temporäre Datei
' Dateiname mit "eta" im Namen werden NICHT eingelesen!!!!!
IfvarTMP.NameLikestrNameAndvarTMP.Name<>_
ThisWorkbook.NameAndLeft(varTMP.Name,1)<>"~"Then
IfNotvarTMP.NameLike"*eta*"Then
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier strSheetZ
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithThisWorkbook.Worksheets(strSheetZ)
' Letzte Zeile bezogen auf Spalte A plus 1
lngLastRow=IIf(Len(.Cells(.Rows.Count,1)),_
.Rows.Count,.Cells(.Rows.Count,1).End(xlUp).Row)+1
' Schleife über alle Zellen des Arrays
ForintTMP=LBound(arrCell)ToUBound(arrCell)
' Hier würde jetzt noch der Dateiname mit Pfad
' in die nächste freie Spalte geschrieben
'.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
' Hier würde jetzt noch der Dateiname
' in die nächste freie Spalte geschrieben
'.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
' Werte über Formel holen, Tabellenblatt über "Const..."
' oben definiert, Zelle über Array. Formel in Spalte A folgende...
strFormula="'"&Mid(varTMP.Path,1,InStrRev(varTMP.Path,"\"))&_
"["&Mid(varTMP.Path,InStrRev(varTMP.Path,"\")+1)&"]"&strSheetQ&"'!"
.Cells(lngLastRow,intTMP+1).Formula="="&strFormula&arrCell(intTMP)
NextintTMP
.Cells(lngLastRow,20).Value=ExecuteExcel4Macro(strFormula&"R18C6")+_
ExecuteExcel4Macro(strFormula&"R26C6")+_
ExecuteExcel4Macro(strFormula&"R34C6")
.Cells(lngLastRow,21).Value=ExecuteExcel4Macro(strFormula&"R21C6")+_
ExecuteExcel4Macro(strFormula&"R29C6")+_
ExecuteExcel4Macro(strFormula&"R37C6")
EndWith
EndIf
EndIf
NextvarTMP
' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
' Dann durchsuche auch alle Unterordner
IfblnTMP=TrueThen
ForEachvarTMPInobjCurrentDir.SubFolders
dirInfovarTMP,strName,blnTMP
NextvarTMP
EndIf
EndSub