Code ja, interpretation leider keine Ahnung ...
11.06.2008 14:59:00
christian
Den Code der drin stand hab ich doch noch gefunden. (Hatt ich wahrscheinlich zum drucken ins Word kopiert)
Aber die Mappe mir den Eingabefeldern wieder generieren gelingt mir nicht, da ich das ganze nicht interpretieren kann. Vielleicht kann mir da jemand helfen?
der Code:
Option Explicit
Sub Start()
Dim strV As String, strE As String, lngUeb As Long, strSpalte As String
Dim lngZ As Long, intDreh As Integer
strE = "xls"
lngUeb = 2
strSpalte = "D"
strV = Cells(2, 2)
If strV = "" Then Exit Sub
If Right(strV, 1) = "\" Then strV = Left(strV, Len(strV) - 1)
If Dir(strV & "\*.xls") = "" Then
MsgBox "Keine xls-Datei gerfunden in" & vbLf & vbLf & strV
Exit Sub
End If
ListFiles strV, strE
Cells.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Cells(1, 5) = "Starts"
For lngZ = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(lngZ, 1) ThisWorkbook.Name Then
Cells(lngZ, 5) = _
ZaehleStarts(strV & "\" & Cells(lngZ, 1), lngUeb + 1, strSpalte, intDreh)
End If
Next lngZ
Columns("A:F").AutoFit
End Sub
Sub ListFiles(strVrz As String, strEndg As String)
Dim FSO As Object, oFolder As Object, oFile As Object
Dim arr As Variant, lngZ As Long, lngS As Long
On Error GoTo ERRORHANDLER
strEndg = UCase(strEndg)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strVrz)
arr = Array("Name", "Erstellung", "Letzte Änd.", "Bytes")
Workbooks.Add 1
Rows(1).HorizontalAlignment = xlCenter
Range(Cells(1, 1), Cells(1, UBound(arr) + 1)) = arr
lngZ = 1
For Each oFile In oFolder.Files
If strEndg = UCase(FSO.GetExtensionName(oFile)) Then
lngZ = lngZ + 1
Cells(lngZ, 1).Value = oFile.Name
Cells(lngZ, 2).Value = oFile.DateCreated
Cells(lngZ, 3).Value = oFile.DateLastModified
Cells(lngZ, 4).Value = oFile.Size
End If
Next oFile
ERRORHANDLER:
If Err > 0 Then
MsgBox "Die Dateien konnten nicht gelistet werden!"
MsgBox "Fehler " & Err.Number & vbLf & Err.Description
End If
Set FSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
End Sub
Function ZaehleStarts(strFile As String, lngU As Long, strSp As String, _
intVor As Integer)
Dim intErg As Integer, lngZ As Long, lngS As Long
Application.EnableEvents = False
' On Error GoTo ERRORHANDLER1
Workbooks.Open strFile, 0, True
' On Error GoTo ERRORHANDLER2
Worksheets(1).Select
lngS = Range(strSp & "1").Column
If intVor = 1000 Then intErg = 1
lngZ = Cells(Rows.Count, lngS).End(xlUp).Row
If lngZ > lngU Then
ZaehleStarts = intErg + Evaluate("SUMPRODUCT((" & strSp & lngU & ":" & strSp & _
lngZ - 1 & "1000))")
intVor = Cells(lngZ, lngS)
Else
ZaehleStarts = "Weniger als 2 Datenzeilen"
End If
ERRORHANDLER2:
ActiveWorkbook.Close False
ERRORHANDLER1:
If Err > 0 Then ZaehleStarts = "Fehler " & Err.Number
Application.EnableEvents = True
End Function