VBA Dateien auslesen langsam

Bild

Betrifft: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 16.10.2015 11:39:50

Hallo zusammen,
ich habe eine Excel-Liste mit den Spalten "Nachname", "Vorname", und "letztes Bearbeitungsdatum". Zu jeder Person soll nun in einem Ordner die passende Datei gefunden werden (Dateiname enthält Nachname + Vorname) und das letzte Bearbeitungsdatum dazu in die Excel-Tabelle geschrieben werden.
Grundsätzlich funktioniert das auch schon auf einem Ordner mit 5 Testdateien/Personen, aber auf dem richtigen Ordner mit über 500 Dateien ist es sehr langsam bzw. habe ich die Ausführung bis jetzt immer nach 10 Minuten abgebrochen (sollte höchstens 1 Minute dauern).
Folgend mein Code - gibt es irgendwelche Tricks, diesen zu optimieren? (VBA/Makro Anfänger und mache das ganze erst seit einer Woche ;-)
Vielen Dank euch schonmal!!


Sub getDateLastModified()
 Dim intRowCount As Integer
    Dim intRow As Integer
    Dim filePath As String
    Dim lastName As String
    Dim firstName As String
    Dim SearchResult As String
    Dim objFSO As Variant
    Dim objFolder As Variant
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder("R:\Folder1")
    Application.ScreenUpdating = False
    intRowCount = Cells(Rows.Count, "F").End(xlUp).Row
    intRow = 2
    filePath = ActiveWorkbook.Sheets("HelpData").Cells(6, "A").Value
    
    Do While intRow <= intRowCount
    
        For Each objFile In objFolder.Files
            
            lastName = Cells(intRow, "F").Value
            firstName = Cells(intRow, "G").Value
            
            'get file name without path
            SearchResult = Split(CStr(objFile), "\")(UBound(Split(CStr(objFile),"\")))
            
            'if a file containing lastName & firstName exists do...
            If StrComp(SearchResult, "") <> 0 And (SearchResult Like "*" & lastName & "*" And  _
SearchResult Like "*" & firstName & "*") Then
                Cells(intRow, "Q") = Split(objFile.DateLastModified, " ")(0)
                intRow = intRow + 1
             End If
             
        Next
    
    Loop
Application.ScreenUpdating = True
End Sub

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: selli
Geschrieben am: 16.10.2015 12:33:02
hallo alex,
schalte mal während der laufzeit die automatische berechnung aus. keine ahnung, ob in deiner mappe viele formeln sind oder du noch andere mappen offen hast.
Application.Calculation = xlCalculationManual
..dein code..
Application.Calculation = xlCalculationAutomatic
gruß
selli

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 16.10.2015 13:15:03
Hi selli,
vielen Dank für deine Antwort! Hilft aber leider auch nicht :-(
LG alex

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: ransi
Geschrieben am: 16.10.2015 13:25:48
Hallo Alex,
Dies sollte etwas Geschwindigkeit bringen:

If StrComp(SearchResult, "") <> 0 Then
    If SearchResult Like "*" & lastName & "*" Then
        If SearchResult Like "*" & firstName & "*" Then
            Cells(intRow, "Q") = Split(objFile.DateLastModified, " ")(0)
            intRow = intRow + 1
        End If
    End If
End If

Welchen Wert hat intRowCount ?
ransi

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 16.10.2015 13:39:38
Hi Ransi,
vielen Dank! Ist leider trotzdem nicht schneller, musste wieder abbrechen...
intRowCount ist 372!
LG alex

Bild

Betrifft: Nicht Dateien auslesen, sonder Fehler...
von: EtoPHG
Geschrieben am: 16.10.2015 13:58:35
im Code, Alex
Angenommen, deine erster Eintrag in F2 und G2 kommen in keinem Filenamen vor, dann wird dein intRow (Zeilenpointer) nie erhöht und dein Loop läuft ewig weiter!
Kommt nur ein Nachname/Vorname nicht in den Filenamen vor, passiert dasselbe.
Gruess Hansueli

Bild

Betrifft: AW: Nicht Dateien auslesen, sonder Fehler...
von: Alex
Geschrieben am: 16.10.2015 14:10:58
Vielen Dank Hansueli! Habe vor "Loop" noch ein intRow = intRow + 1 eingefügt, das sollte das Problem ja eigentlich lösen, oder? Klappt aber leider trotzdem noch nciht :-(
LG alex

Bild

Betrifft: AW: Nicht Dateien auslesen, sonder Fehler...
von: Alex
Geschrieben am: 16.10.2015 14:50:41
Hier mein neuer if-Block:

If StrComp(SearchResult, "") <> 0 Then
                If SearchResult Like "*" & lastName & "*" Then
                    If SearchResult Like "*" & firstName & "*" Then
                                Cells(intRow, "Q") = Split(objFile.DateLastModified, " ")(0)
                                intRow = intRow + 1
                    End If
                End If
            End If
        Next
        
        intRow = intRow + 1
    
    Loop


Bild

Betrifft: AW: Nicht Dateien auslesen, sonder Fehler...
von: EtoPHG
Geschrieben am: 16.10.2015 14:51:25
Hallo Alex,
Eine Beschreibung, wie Klappt aber leider trotzdem noch nciht :-( hat einen Informationsgehalt von Null. Was klappt nicht? Wie äussert sich der Fehler? ...
Wenn du den Index vor dem 'Zeilen'-Loop erhöhst, wird nur jeder 2te Vorname/Name geprüft, sofern ein solcher in den Filenamen vorkommt, weil du den Index im 'File'-Loop bereits um 1 inkrementiert hast.
Warum schreibst du die extrahierten Filenamen und ModifiedDate nicht in einen freien Zellbereich. Dann kannst du den Rest mit Formeln lösen. Das wäre x-mal schneller!
Gruess Hansueli

Bild

Betrifft: AW: Nicht Dateien auslesen, sonder Fehler...
von: EtoPHG
Geschrieben am: 16.10.2015 14:51:26
Hallo Alex,
Eine Beschreibung, wie Klappt aber leider trotzdem noch nciht :-( hat einen Informationsgehalt von Null. Was klappt nicht? Wie äussert sich der Fehler? ...
Wenn du den Index vor dem 'Zeilen'-Loop erhöhst, wird nur jeder 2te Vorname/Name geprüft, sofern ein solcher in den Filenamen vorkommt, weil du den Index im 'File'-Loop bereits um 1 inkrementiert hast.
Warum schreibst du die extrahierten Filenamen und ModifiedDate nicht in einen freien Zellbereich. Dann kannst du den Rest mit Formeln lösen. Das wäre x-mal schneller!
Gruess Hansueli

Bild

Betrifft: AW: Nicht Dateien auslesen, sonder Fehler...
von: Alex
Geschrieben am: 16.10.2015 14:56:39
Hallo Hansueli,
meinte damit, dass mein Problem mit der Laufzeit noch immer nicht gelöst ist und das Programm ewig braucht bzw. "Excel reagiert nicht" auftaucht und ich nach 2 Minuten abbreche.
Deine andere Idee hatte ich mir auch schon überlegt, habe allerdings in der gegebenen Excel-Tabelle noch eine Spalte mit "Gruppe" für jede Person, und nach dieser Gruppe soll am Ende sortiert werden, damit die Gruppenleader die letzten Bearbeitungsdaten ihrer Gruppe sehen. Ich glaube das geht nicht mit Formeln, oder?
Trotzdem vielen Dank!
LG
Alex

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Daniel
Geschrieben am: 16.10.2015 17:27:35
Hi
probier mal, ob das nicht schneller ist.
die Dateien müssen in der Reihenfolge "NachName-Vorname" benannt sein.

Sub test()
Dim datei As String
Dim Pfad As String
Dim arrNamen
Dim arrDatum
Dim z As Long
Pfad = "R:\Folder1\"
arrNamen = Range("F2:G" & Cells(Rows.Count, 6).Row).Value
ReDim arrDatum(1 To UBound(arrNamen, 1), 1 To 1)
For z = 1 To UBound(arrNamen, 1)
    datei = Dir(Pfad & "*" & arrNamen(z, 1) & "*" & arrNamen(z, 2) & "*")
    If datei = "" Then
        arrDatum(z, 1) = "Datei fehlt"
    Else
        arrDatum(z, 1) = FileDateTime(Pfad & datei)
    End If
Next
Cells(2, "Q").Resize(UBound(arrDatum, 1), 1).Value = arrDatum
End Sub

ich hoffe mal es funktioniert, weil testen kann ich es ja nicht.
Gruß Daniel

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Daniel
Geschrieben am: 16.10.2015 17:28:35
Hi
probier mal, ob das nicht schneller ist.
die Dateien müssen in der Reihenfolge "NachName-Vorname" benannt sein.

Sub test()
Dim datei As String
Dim Pfad As String
Dim arrNamen
Dim arrDatum
Dim z As Long
Pfad = "R:\Folder1\"
arrNamen = Range("F2:G" & Cells(Rows.Count, 6).Row).Value
ReDim arrDatum(1 To UBound(arrNamen, 1), 1 To 1)
For z = 1 To UBound(arrNamen, 1)
    datei = Dir(Pfad & "*" & arrNamen(z, 1) & "*" & arrNamen(z, 2) & "*")
    If datei = "" Then
        arrDatum(z, 1) = "Datei fehlt"
    Else
        arrDatum(z, 1) = FileDateTime(Pfad & datei)
    End If
Next
Cells(2, "Q").Resize(UBound(arrDatum, 1), 1).Value = arrDatum
End Sub

ich hoffe mal es funktioniert, weil testen kann ich es ja nicht.
Gruß Daniel

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Daniel
Geschrieben am: 16.10.2015 17:28:38
Hi
probier mal, ob das nicht schneller ist.
die Dateien müssen in der Reihenfolge "NachName-Vorname" benannt sein.

Sub test()
Dim datei As String
Dim Pfad As String
Dim arrNamen
Dim arrDatum
Dim z As Long
Pfad = "R:\Folder1\"
arrNamen = Range("F2:G" & Cells(Rows.Count, 6).Row).Value
ReDim arrDatum(1 To UBound(arrNamen, 1), 1 To 1)
For z = 1 To UBound(arrNamen, 1)
    datei = Dir(Pfad & "*" & arrNamen(z, 1) & "*" & arrNamen(z, 2) & "*")
    If datei = "" Then
        arrDatum(z, 1) = "Datei fehlt"
    Else
        arrDatum(z, 1) = FileDateTime(Pfad & datei)
    End If
Next
Cells(2, "Q").Resize(UBound(arrDatum, 1), 1).Value = arrDatum
End Sub

ich hoffe mal es funktioniert, weil testen kann ich es ja nicht.
Gruß Daniel

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 21.10.2015 11:47:12
Hi Daniel,
vielen Dank für deinen Code! Er läuft schon mal durch!
Leider wird noch bei jeder Datei "Datei fehlt" eingetragen und die Spalte mit "Datei fehlt" geht bis ins unendliche.
Vielen Dank nochmal für deine Hilfe!
Alex

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Daniel
Geschrieben am: 21.10.2015 11:57:19
Hi
schwierig.
es könnte ja auch daran liegen, dass die Namen in der List anders geschrieben sind in der Datei.
ich bräuchte jetzt deine Datei und einen Screenshot aus dem Dateiexplorer von dem Verzeichnis, in dem die Daten liegen.
Gruß Daniel

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 21.10.2015 14:45:42
Hi Daniel,
erstmal ganz lieben Dank dir! Hier meine Liste zum Testen:
https://www.herber.de/bbs/user/100943.xlsm
Liegt es vielleicht daran, dass der Dateiname nicht nur aus Vorname-Nachname besteht?
Userbild
VG
Alex

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Daniel
Geschrieben am: 21.10.2015 16:05:53
Hi
zwei Fehler (einer von dir, einer von mir)
1. Pfad = "R:\Folder1\"
2. arrNamen = Range("B2:C" & Cells(Rows.Count, "C").End(xlUP).Row).Value
dass der Dateiname noch mehr Text enthält macht nichts, dafür sind die Jokerzeichen * da.
es müssen nur Nach- und Vorname im Dateinamen vorkommen und in der richtigen Reihenfolge stehen.
welcher Text davor, danach und dazwischen steht, spielt aufgrund des Jokers keine Rolle.
Gruß Daniel

Bild

Betrifft: AW: VBA Dateien auslesen langsam
von: Alex
Geschrieben am: 21.10.2015 16:48:06
Hi Daniel,
vielen vielen Dank für deine Hilfe!!
Jetzt funktioniert alles einwandfrei!
Wirklich super! :)
VG
Alex

 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA Dateien auslesen langsam"