1.8k Aufrufe
Gefragt in Tabellenkalkulation von marie Experte (2k Punkte)
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

4 Antworten

0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi :-)

bei diesen Beispiel werden zwei Arrays erstellt und einige Ereignisse abgeschaltet:-)

gruss nighty

Private strList() As String

Private ordlist() As String

Private lngCount As Long

Public Sub Einlesen()
Call EventsOff
Dim IndexStr As Long
SearchFiles "C:\Temp", "*.xls"
For IndexStr = 0 To UBound(strList)

'ordlist (IndexStr) name des ordners
'strList (IndexStr) name der datei
' bei array sind parallel aufgebaut

Next IndexStr
Next IndexOrd
Call EventsOn
End Sub

Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
ReDim Preserve strList(lngCount)
ReDim Preserve ordlist(lngCount)
strList(lngCount) = objFile.Name
ordlist(lngCount) = strFolder
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub

Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
0 Punkte
Beantwortet von marie Experte (2k Punkte)
Sorry, konnte Dir gestern nicht mehr antworten, habe es zweimal versucht, beim ersten mal ist nur mein Rechner ausgegangen, bevor ich abschicken konnte, wegen kurzem Stromausfall. Beim zweiten mal war dann stundenlang Totalausfall von Kabel Deutschland und jetzt schick ich schnell ab, denn eben hat es gerade wieder gedonnert.

Alles prima, tausend Dank

Gruß Marie
0 Punkte
Beantwortet von nighty Experte (6.6k Punkte)
hi :-)

gruss nighty

Next IndexOrd war noch datenmüll

korrigiert

Public Sub Einlesen()
Call EventsOff
Dim IndexStr As Long
SearchFiles "C:\Temp", "*.xls"
For IndexStr = 0 To UBound(strList)

'ordlist (IndexStr) name des ordners
'strList (IndexStr) name der datei
' beide array sind parallel aufgebaut

Next IndexStr
Call EventsOn
End Sub
0 Punkte
Beantwortet von marie Experte (2k Punkte)
Na ja, soviel versteh ich schon vom Programmieren, dass ich damit kein Problem hatte :-)

Hab die ordlist eh ganz rausgelassen, brauch ich ja nicht.

Läuft so schnell wie vorher mit dem FileSearch, kann den Schrott also drinlassen, dass ich jedesmal alle Rechnungen neu einlese. :-)

Vielleicht braucht er das ja ab und an, dass er Schrottrechnungen entfernt und dann wieder eine ordentliche Liste hat. Kann ja sein, weiß ich nicht.

In jedem Fall läuft es supi, tausend Dank nochmal.

Gruß Marie
...