AW: Summe von Feldern aus mehreren Dateien
11.04.2014 17:06:45
Feldern
Hallo,
habe dir mal was zusammengestellt.
Ordnerpfad anpassen!
Überordner wird aus Datum erstellt
Evtl. Filter für Datei anpassen.
Ausgabe erfolgt in der Tabelle1, evtl. auch anpassen.
kommt als Code in Modul1
Option Explicit
Sub Start()
Dim strPath$, sOrdnerName$, strAddress$
Dim ArFile(), nCounter&, sPatternFile$
sOrdnerName = Format(Date, "dd_mm_yy") 'Unterordner akt. Datum
strPath = "G:\1 Forum\" 'Ordnerpfad
sPatternFile = "SIP_GW*.xlsm" 'Filter für dateien
strAddress = Range("H8:H39").Address 'Adressbereich
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\")
strPath = strPath & sOrdnerName & "\"
ListFilesInFolder ArFile, strPath, sPatternFile, False, False, nCounter
If nCounter > 0 Then
ArrayTranspose ArFile
strAddress = "General'!" & Range(strAddress).Address(ReferenceStyle:=xlR1C1, External:=False)
Redim Preserve ArFile(1 To Ubound(ArFile), 1 To 2)
For nCounter = 1 To Ubound(ArFile)
ArFile(nCounter, 2) = ExecuteExcel4Macro("SUM('" & strPath & "[" & ArFile(nCounter, 1) & "]" & strAddress & ")")
Next nCounter
With Tabelle1
.Range("A2", .Cells(.Rows.Count, 2)).Clear
With .Range("A2").Resize(Ubound(ArFile), Ubound(ArFile, 2))
.Value = ArFile
.EntireColumn.AutoFit
End With
End With
End If
End Sub
Sub ListFilesInFolder(ArFiles(), SourceFolderName As String, Optional DateiFormat As String = "*.*", Optional IncludeSubfolders As Boolean = False, Optional Full_Path As Boolean = False, Optional nCounter&)
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
'1.Parameter ein Array für die Daten
'2.Parameter Ordner, wo soll gesucht werden?
'3.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle
'4.Parameter mit Unterordner = True, Optional False ist ohne
'5.Parameter kompl. Pfad ausgeben = True, Optional nur Dateiname = False
'6.Parameter ein Zähler
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo Err_Zugriff: 'sollte Ordener geschützt sein oder nicht vorhanden
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
If Not FileItem.Attributes And 2 Then 'ohne versteckte
nCounter = nCounter + 1
Redim Preserve ArFiles(1 To nCounter)
If Full_Path Then
ArFiles(nCounter) = FileItem
Else
ArFiles(nCounter) = Right$(FileItem, Len(FileItem) - InStrRev(FileItem, "\"))
End If
End If
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder ArFiles, SubFolder.Path, DateiFormat, IncludeSubfolders, Full_Path, nCounter
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
If Err.Number = 76 Then
MsgBox Err.Description & vbCr & vbCr & SourceFolderName
End If
End Sub
Sub ArrayTranspose(varArray)
Dim nRow&, nCol&, NewArray()
Dim nRowCount&, nColCount&
If Not IsArray(varArray) Then
MsgBox "Kein Array!", vbCritical
Exit Sub
End If
On Error Resume Next
Redim NewArray( _
1 To Ubound(varArray, 2) - Lbound(varArray, 2) + 1, _
1 To Ubound(varArray) - Lbound(varArray) + 1)
If Err.Number = 0 Then
For nRow = Lbound(varArray) To Ubound(varArray)
nColCount = nColCount + 1
For nCol = Lbound(varArray, 2) To Ubound(varArray, 2)
nRowCount = nRowCount + 1
NewArray(nRowCount, nColCount) = varArray(nRow, nCol)
Next nCol
nRowCount = 0
Next nRow
Else
Redim NewArray( _
1 To Ubound(varArray) - Lbound(varArray) + 1, 1 To 1)
For nCol = Lbound(varArray) To Ubound(varArray)
nRowCount = nRowCount + 1
NewArray(nRowCount, 1) = varArray(nCol)
Next nCol
End If
varArray = NewArray
End Sub
Gruß Tino