Hallo ihr Excel-Experten,
leider finde ich unter dem Stichwort FSO hier keinerlei Einträge. Benutzt ihr nicht das FSO? Welche andere Möglichkeit habe ich FileSearch zu ersetzen, das ja nicht mehr läuft mir neueren Officeversionen?
Habe in meinem Code das FileSearch durch FSO ersetzt und das läuft jetzt unzumutbar langsam. Allerdings hab ich auch Mattscheibe und nicht hingekriegt gleich den Filenamen ohne Pfad einzulesen, warum auch immer das nicht gelaufen ist (vielleicht die Hitze). Aber ich glaube nicht, dass das Abtrennen des Pfadnamens den gesamten Geschwindigkeitsverlust ausmacht. Das FileSearch lief genauso umständlich viel schneller.
Die Rechnungen sind abgelegt mit der führenden Rechnungsnummer im Dateinamen, Unterstrich, Kundenname, Unterstrich, Kundennummer, Unterstrich, Rechnungsdatum.xls. Das Rechnungsdatum ist mit Punkten gespeichert, vielleicht ist es das, was die Sache so langsam macht?
Hier ein Beispiel für einen Dateinamen:
1943_Walter Müller_3644_11.07.2013.xls
in der Datei Rechnungen13.xls wird eingelesen in Spalte A die Rechnungsnummer, in Spalte B der Name, in Spalte C die Kundennummer und in Spalte D das Rechnungsdatum und so sortiert, dass die letzte Rechnungsnummer in Zeile 1 steht.
Der Kunde hat teilweise circa 2000 Rechnungen in dem Verzeichnis, die ich jedesmal lösche aus der Datei Rechnungenxx.xls und neu eintrage. Wenn das
schneller geht wäre es auch möglich, dass ich nur die Rechnungsnummer vergleiche und nur dann sämtliche Dateien neu einlese, wenn die in dem Verzeichnis vorhandenen Rechnungen nicht mit der Liste übereinstimmen. Ansonsten müsste ich dann nur die höchste Rechnungsnummer herauslesen.
Mal gespannt, ob mir einer helfen kann und ob ich mich verständlich genug ausgedrückt habe. Wäre super.
Gruß Marie
Hier mal mein Code.
Private Function GetAFile(strRePfad As String)
Dim lngCount As Long
Dim lngZahl As Long
'Dim varFoundFile As String
Dim intZeile As Integer
Dim intSpalte As Integer
Dim intPos As Integer
' neu 2013 weil FileSearch nicht mehr geht ab Office 2007
Dim StTyp As String
Dim objFSO As Object
Dim varFoundFile As Variant ' Object und String zum abtrennen der Teile
Set objFSO = CreateObject("Scripting.Filesystemobject")
On Error GoTo Dateiliste_Hyperlinks_Error
'letzte beschriebene Zeile ermitteln und alles löschen
lngZahl = fktletzteZeile
Worksheets("Tabelle1").Range(Cells(1, 1), Cells(lngZahl, 4)).Clear
' Verzeichnis Rechnungen laufendes Jahr durchsuchen und Rechnungen neu eintragen
StTyp = "xls" ' Dateityp
lngCount = CountFiles(strRePfad) ' 2013 zählt die Dateien in dem Rechnungsverzeichnis des laufenden Jahres
If lngCount > 0 Then
strZeile = 1
'Dateien auslesen
For Each varFoundFile In objFSO.GetFolder(strRePfad).Files ' Schleife über alle Dateien
'Dateityp feststellen
If UCase(objFSO.GetExtensionName(varFoundFile)) = UCase(StTyp) Then
'Pfad abtrennen
varFoundFile = fGetFileName(varFoundFile)
' dann steht Rechnungsnummer vorne
If Val(varFoundFile) > 0 Then ' nur Files mit Rechnungsnummer eintragen
varFoundFile = Left$(varFoundFile, Len(varFoundFile) - 4) ' Endung .xls abschneiden
For intSpalte = 1 To 3 ' 1 Rechnungsnummer 2 Name 3 Kundennummer 4 Datum
intPos = InStr(1, varFoundFile, "_")
Worksheets("Tabelle1").Cells(strZeile, intSpalte) = Left$(varFoundFile, intPos - 1)
varFoundFile = Right$(varFoundFile, Len(varFoundFile) - intPos) ' Rest abschneiden
If intSpalte = 3 Then Worksheets("Tabelle1").Cells(strZeile, 4) = varFoundFile ' Rest in 4. Spalte schreiben
Next intSpalte
strZeile = strZeile + 1
End If
End If
Next
End If
Columns.AutoFit ' Passt die Spaltenbreite automatisch an
'letzte beschriebene Zeile ermitteln und absteigend sortieren
lngZahl = fktletzteZeile
Worksheets("Tabelle1").Range(Cells(1, 1), Cells(lngZahl, 4)).Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
GetAFile_exit:
Set objFSO = Nothing
Exit Function
Dateiliste_Hyperlinks_Error:
With Err
If .Number = 5 Then ' ungültiger Prozeduraufruf unbekannter Herkunft bei manchen Verzeichnissen
'Fehler in FileSearch, wenn das Hauptverzeichnis die gesuchte Datei "*.bla enthält"
' bewirkt leider, dass alle Dateien eingelesen werden
Resume Next
Else
MsgBox "Error " & Err.Number & " (" & Err.Description & ")", vbCritical, "Fehler in GetAFile"
End If
End With
Resume GetAFile_exit
End Function
Function CountFiles(Directory As String) As Double
' 2013 ersatz für fileSearch
'Function purpose: To count all files in a directory
Dim fso As Object, _
objFiles As Object
'Create objects to get a count of files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set objFiles = fso.GetFolder(Directory).Files
If Err.Number <> 0 Then
CountFiles = 0
Else
CountFiles = objFiles.Count
End If
On Error GoTo 0
End Function
Private Function fGetFileName(strFullPath) As String
Dim intPos As Integer
Dim intLen As Integer
intLen = Len(strFullPath)
If intLen Then
For intPos = intLen To 1 Step -1
'Find the last \
If Mid$(strFullPath, intPos, 1) = "\" Then
fGetFileName = Mid$(strFullPath, intPos + 1)
Exit Function
End If
Next intPos
End If
End Function