Geschlossene Dateien - Range in Masterdatei in Zeilen auslesen...

' Variablendeklaration erforderlich
OptionExplicit
' Der Tabellenblattname in den auszulesenden Dateien
ConststrSheetQAsString="Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
ConststrSheetZAsString="Total"
' Dieser Bereich wird ausgelesen
ConststrRange1AsString="B2:C2"
ConststrRange2AsString="B3:C3"
ConststrRange3AsString="B4:C4"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 24.04.2014
' Purpose   : Geschlossene Dateien Range auslesen...
'--------------------------------------------------------------------------
PublicSubMain()
DimstCalcAsInteger
DimstrDirAsString
DimobjFSOAsObject
DimobjDirAsObject
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
.ScreenUpdating=False
.AskToUpdateLinks=False
.EnableEvents=False
stCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
SetobjFSO=CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
strDir=ThisWorkbook.Path&Application.PathSeparator
' Fester Ordner vorgegeben
'strDir = "C:\Temp\Test\"
strDir=IIf(Right(strDir,1)<>"\",strDir&"\",strDir)
SetobjDir=objFSO.GetFolder(strDir)
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier das Objekt (bzw. die Variable) strSheetZ
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithThisWorkbook.Worksheets(strSheetZ)
.Rows("2:"&.Rows.Count).ClearContents
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfoobjDir,"*.xls*"' Ohne Unterordner
' Formeln entfernen - Werte bleiben erhalten
.UsedRange.Value=.UsedRange.Value
EndWith
Fin:
' Die Applikation aufwecken
WithApplication
.Goto(ThisWorkbook.Worksheets(strSheetZ).Range("A1")),True
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=stCalc
.DisplayAlerts=True
EndWith
' Setze die Objektvariablen auf Nothing
SetobjDir=Nothing
SetobjFSO=Nothing
' 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      : 24.04.2014
' Purpose   : Geschlossene Dateien - Range auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub - Optional mit Unterordner
PublicSubdirInfo(ByValobjCurrentDirAsObject,ByValstrNameAsString,_
OptionalByValblnTMPAsBoolean=False)
DimobjWorkbookAsWorkbook
DimstrFormulaAsString
DimlngLastRowAsLong
DimvarTMPAsVariant
' 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
' Dafür die Abfrage nach der Tilde "~"
IfvarTMP.NameLikestrNameAndvarTMP.Name<>_
ThisWorkbook.NameAndLeft(varTMP.Name,1)<>"~"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 B plus 1
lngLastRow=IIf(Len(.Cells(.Rows.Count,2)),_
.Rows.Count,.Cells(.Rows.Count,2).End(xlUp).Row)+1
' Dateiname mit Pfadangabe
'.Cells(lngLastRow, 1).Value = varTMP.Path
' Hier nur Dateiname ohne Pfadangabe
.Cells(lngLastRow,1).Value=varTMP.Name
' Werte über Formel holen, Tabellenblatt über "Const..."
' oben definiert, Range auch oben definiert.
' Formel in Spalte B:G. Datumsformat setzen
With.Range(.Cells(lngLastRow,2),.Cells(lngLastRow,3))
.NumberFormat="m/d/yyyy"
.FormulaArray="='"&Mid(varTMP.Path,1,_
InStrRev(varTMP.Path,"\"))&"["&_
Mid(varTMP.Path,InStrRev(varTMP.Path,_
"\")+1)&"]"&_
strSheetQ&"'!"&strRange1
EndWith
With.Range(.Cells(lngLastRow,4),.Cells(lngLastRow,5))
.NumberFormat="m/d/yyyy"
.FormulaArray="='"&Mid(varTMP.Path,1,_
InStrRev(varTMP.Path,"\"))&"["&_
Mid(varTMP.Path,InStrRev(varTMP.Path,_
"\")+1)&"]"&_
strSheetQ&"'!"&strRange2
EndWith
With.Range(.Cells(lngLastRow,6),.Cells(lngLastRow,7))
.NumberFormat="m/d/yyyy"
.FormulaArray="='"&Mid(varTMP.Path,1,_
InStrRev(varTMP.Path,"\"))&"["&_
Mid(varTMP.Path,InStrRev(varTMP.Path,_
"\")+1)&"]"&_
strSheetQ&"'!"&strRange3
EndWith
EndWith
EndIf
NextvarTMP
' Wenn die Variable blnTMP "True" ist (in der Sub "Main" vorgegeben)
' Dann durchsuche auch alle Unterordner
IfblnTMP=TrueThen
ForEachvarTMPInobjCurrentDir.SubFolders
dirInfovarTMP,strName,blnTMP
NextvarTMP
EndIf
' Setze die Objektvariable auf Nothing
SetobjWorkbook=Nothing
EndSub