AW: Daten auswerten, aber wie ?
08.04.2014 11:33:49
Tino
Hallo,
versuche es mit diesem Code.
Sub Test()
Dim strPath$
Dim FSO As Object, objFile As Object, objOrdner As Object
Dim nDate As Date, MaxDate As Date
Dim ArFiles(), ArOrdner(), nPath
Dim maxRow&, maxRowExWB&, n&
'Pfad zu den Dateien anpassen
strPath = "C:\Users\Thomas\Desktop\Daten"
nDate = Tabelle1.Range("A2") 'letztes Datum
Set FSO = CreateObject("Scripting.FileSystemObject")
Redim Preserve ArOrdner(n)
ArOrdner(n) = strPath: n = n + 1
GetSubFolders ArOrdner, strPath, FSO, n
If n > 0 Then
n = 0
For Each nPath In ArOrdner
Set objOrdner = FSO.getfolder(nPath)
For Each objFile In objOrdner.Files
If objFile.Name Like "*.xlsx" Then
If objFile.DateCreated > nDate Then
Redim Preserve ArFiles(n)
ArFiles(n) = objFile
If MaxDate < objFile.DateCreated Then MaxDate = objFile.DateCreated
n = n + 1
End If
End If
Next objFile
Next nPath
End If
If n > 0 Then
Events_ False
n = n - 1
Redim Preserve ArFiles(n)
For n = Lbound(ArFiles) To n
With Workbooks.Open(ArFiles(n), ReadOnly:=True)
With .Sheets(1)
maxRowExWB = .Cells(.Rows.Count, 3).End(xlUp).Row
If maxRowExWB > 1 Then
.Range(.Cells(2, 3), .Cells(maxRowExWB, 3)).Copy
maxRow = Tabelle1.Cells(Tabelle1.Rows.Count, 3).End(xlUp).Row + 1
Tabelle1.Cells(maxRow, 3).PasteSpecial
End If
End With
.Close False
End With
Next n
Tabelle1.Range("A2").Value = MaxDate
End If
If n > 0 Then
With Tabelle1
.Columns("E:F").Clear
.Columns(3).Copy Tabelle1.Columns(5)
.Cells(1, 5) = "Daten Sortiert"
.Cells(1, 6) = "Anzahl"
.Range("E1:F1").Font.Bold = True
.Columns(5).RemoveDuplicates Columns:=1, Header:=xlYes
.Columns(3).Sort .Cells(1, 3), Order1:=xlAscending, Header:=xlYes
With .Range(.Cells(1, 5), .Cells(.Rows.Count, 5).End(xlUp))
.Sort .Cells(1, 1), Order1:=xlAscending, Header:=xlYes
End With
With .Range(.Cells(2, 5), .Cells(.Rows.Count, 5).End(xlUp))
.Offset(0, 1).FormulaR1C1 = "=COUNTIF(C3,RC[-1])"
End With
.Columns("E:F").EntireColumn.AutoFit
End With
Events_ True
Else
MsgBox "keine neuen Daten!"
End If
End Sub
Private Sub GetSubFolders(myAr, strPfad As String, FSO As Object, Optional LCount As Long)
Dim FO As Object, FU As Object, F As Object
Set FO = FSO.getfolder(strPfad)
Set FU = FO.SubFolders
On Error GoTo ErrZugriff: 'falls zugriff verweigert
For Each F In FU
If F.Attributes = 16 Then
Redim Preserve myAr(LCount)
myAr(LCount) = F.Path
LCount = LCount + 1
GetSubFolders myAr, F.Path, FSO, LCount
End If
Next
ErrZugriff:
End Sub
Sub Events_(booOn As Boolean)
Static iCalc%
With Application
If booOn = False Then iCalc = .Calculation
.EnableEvents = booOn
.ScreenUpdating = booOn
.DisplayAlerts = booOn
.Calculation = IIf(booOn, iCalc, xlCalculationManual)
End With
End Sub
Gruß Tino