Dateilöschmakro beschleunigen

11.01.2026 12:52:17

Christian

Hallo, ich wollte mal die Experten fragen, ob sich der unten stehende Teil meines Makros beschleunigen lässt. Ausgangspunkt sind halt sehr viele Daten, zzt. 1238 Einträge in Ergebnis!I, 111.073 Dateien in Bilder2, davon 15254, deren Name mit AZN beginnt.

Ziel des Makros ist, alle Dateien zu löschen, deren Name 1. mit AZN, aber 2. mit keinem der Texte in Ergebnis!I beginnt. Alle Texte in Ergebnis!I beginnen mit AZN.

Hat da jemand Vorschläge

Danke
Christian

Kleiner Nachtrag, die Variablen wurden größtenteils schon zu Beginn des Makros definiert, das Makro ist so wie es zzt ist, lauffähig.

 ' =====================================================

    ' 7) AZN Cleanup in D:\Bilder2

    ' =====================================================

    Set allowedDict = CreateObject("Scripting.Dictionary")

    lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row



    If lastErgRow > 1 Then

        ergArr = wsErgebnis.Range("I1:I" & lastErgRow).Value

        For j = 1 To UBound(ergArr, 1)

            If Trim(ergArr(j, 1)) > "" Then allowedDict(Trim(ergArr(j, 1))) = 1

        Next j

    End If



    For Each fileObj In fso.GetFolder(folderBilder).files

        If UCase(Left(fileObj.Name, 3)) = "AZN" Then

            Dim keep As Boolean: keep = False

            For Each key In allowedDict.Keys

                If LCase(Left(fileObj.Name, Len(key))) = LCase(key) Then

                    keep = True: Exit For

                End If

            Next key

            If Not keep Then fso.DeleteFile fileObj.Path, True

        End If

    Next fileObj

eigene Idee

11.01.2026 13:07:23

Christian

Auch die Dateinamen, die mit AZN beginnen in ein Dictionary und die Dictionaries vergleichen, um herauszufinden, welche Dateien gelöscht werden sollen und diese dann löschen. Aber wenn jemand noch eine bessere Idee hat, bin ich gerne dafür offen.

    ' =====================================================

    ' 7) AZN Cleanup in D:\Bilder (schnell, mit Dictionary)

    ' =====================================================

    Dim dictAZN As Object, keepDict As Object

    Dim fileObj As Object, key As Variant

    Dim fileName As String

    Dim lastErgRow As Long

    Dim ergArr As Variant



    ' --- 1) AllowedDict aus Spalte I aufbauen ---

    Set allowedDict = CreateObject("Scripting.Dictionary")

    lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row



    If lastErgRow > 1 Then

        ergArr = wsErgebnis.Range("I1:I" & lastErgRow).Value

        For j = 1 To UBound(ergArr, 1)

            If Trim(ergArr(j, 1)) > "" Then allowedDict(Trim(ergArr(j, 1))) = 1

        Next j

    End If



    ' --- 2) Alle AZN-Dateien in D:\Bilder sammeln ---

    Set dictAZN = CreateObject("Scripting.Dictionary")

    For Each fileObj In fso.GetFolder(folderBilder).Files

        If UCase(Left(fileObj.Name, 3)) = "AZN" Then

            dictAZN(fileObj.Name) = fileObj.Path

        End If

    Next fileObj



    ' --- 3) Dateien, die behalten werden sollen, markieren ---

    Set keepDict = CreateObject("Scripting.Dictionary")

    For Each key In allowedDict.Keys

        For Each fileName In dictAZN.Keys

            ' Prüfen, ob Dateiname mit erlaubtem Key beginnt

            If UCase(Left(fileName, Len(key))) = UCase(key) Then

                keepDict(fileName) = True

            End If

        Next fileName

    Next key



    ' --- 4) Dateien löschen, die nicht in keepDict sind ---

    For Each fileName In dictAZN.Keys

        If Not keepDict.Exists(fileName) Then

            fso.DeleteFile dictAZN(fileName), True

        End If

    Next fileName

AW: eigene Idee

11.01.2026 18:49:41

schauan

Im Prinzip könnte das ganz kurz gehen.
Beispiel:

in A1:A3 stehen Deine auszuschließenden Dateinamen. Diese nimmst Du in ein Array:
arrnot = WorksheetFunction.Transpose(Range("A1:A3").Value)

Per Filter prüfst Du, ob der zu löschende Dateiname in dem Array enthalten ist:
arrtest = UBound(Filter(arrnot, Dateiname))

Ist er nicht enthalten, wird -1 zurückgegeben, ansonsten 0

   lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

   arrnot = WorksheetFunction.Transpose(Range("I1:I" & lastErgRow).Value)

   For Each fileObj In fso.GetFolder(folderBilder).files

        If UCase(Left(fileObj.Name, 3)) = "AZN" And UBound(Filter(arrnot, Dateiname)) Then fso.DeleteFile fileObj.Path, True

   Next fileObj

I1 ggf. anpassen ...

AW: eigene Idee

11.01.2026 18:55:04

Christian

Hallo schauan,

danke für deinen Beitrag
ok, meine VBA Kenntnisse haben Grenzen, verbesser mich bitte, wenn ich falsch liege, aber prüft das nicht verkehrt rum, also ob der Text in Spalte I den Dateinamen enthält?
anstatt das der Dateiname mit dem Text in Spalte I beginnt.

Gruß
Christian

AW: eigene Idee

11.01.2026 19:18:46

schauan

Dateiname muss im letzten Code natürlich fileObj.Name sein - das war noch von der Erklärung oberhalb. :-(

Beim Filtern gleicht das Makro ab, ob der fileObj.Name in dem Array enthalten ist. Wenn nein, wird gelöscht.
Du kannst das auch mal leicht prüfen:

Schreib in A1:A3 irgendwas rein, z.B.
ABC
DEF
GHI
Dann testest Du:
Sub test()
arrnot = WorksheetFunction.Transpose(Range("A1:A3").Value)
If UBound(Filter(arrnot, "ABC")) Then MsgBox 1
If UBound(Filter(arrnot, "ABCD")) Then MsgBox 2
End Sub

AW: eigene Idee

12.01.2026 11:00:33

schauan

Ergänzung:

1) Das Prinzip passt uneingeschränkt, wenn die Daten in der Tabelle die gleiche Länge und Schreibweise (groß/klein) haben.
2) Du musst den Dateinamen natürlich auf die entsprechende Länge kürzen.
3) bei unterschiedlicher Schreibweise (groß/klein) kommt ein Schritt dazu

1)+2)
Also dann z.B. bei 5 Zeichen (AZN=3 +2)

   lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

   arrnot = WorksheetFunction.Transpose(Range("I1:I" & lastErgRow).Value)

   For Each fileObj In fso.GetFolder(folderBilder).files

        If UCase(Left(fileObj.Name, 3)) = "AZN" And UBound(Filter(arrnot, left(fileObj.Name,5))) Then fso.DeleteFile fileObj.Path, True

   Next fileObj

bzw. zum ausprobieren

Schreib in A1:A3 irgendwas rein, z.B.
ABCDE
DEFGH
GHIJK
Dann testest Du:
Sub test()
arrnot = WorksheetFunction.Transpose(Range("A1:A3").Value)
If UBound(Filter(arrnot, Left("ABCDEFG",5))) Then MsgBox 1
If UBound(Filter(arrnot, Left("ABCDFGH",5))) Then MsgBox 2
End Sub

3)
Code zum Test:
Sub test()
arrnot = UCase(WorksheetFunction.TextJoin(";", True, Range("A1:A3").Value))
arrnot = Split(arrnot, ";")
If UBound(Filter(arrnot, UCase(Left("ABCDEFG", 5)))) Then MsgBox 1
If UBound(Filter(arrnot, Left("ABCDFGH", 5))) Then MsgBox 2
End Sub

praktisch:

   lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

   arrnot = UCase(WorksheetFunction.TextJoin(";", True, Range("I1:I" & lastErgRow).Value))

   arrnot = Split(arrnot, ";")

   For Each fileObj In fso.GetFolder(folderBilder).files

        If UCase(Left(fileObj.Name, 3)) = "AZN" And UBound(Filter(arrnot, Ucase(left(fileObj.Name,5)))) Then fso.DeleteFile fileObj.Path, True

   Next fileObj

AW: eigene Idee

12.01.2026 11:12:02

Christian

Hallo schauan,

sorry aber jetzt hab ich vollkommen die Orientierung verloren. Was ich noch verstehe ist dass dein Textmakro prüft, ob einer der 3 Texte aus A:C in den Texten, die im Makro stehen, vorkommt und die Zeilennummer ausgibt. Aber in wiefern mir das bei meiner Fragestellung weiterhilft, habe ich keine Ahnung.

Wie ich gesagt hab, die Familie hat mich gestern spontan gefragt, ob ich mitfahre ein paar Tage ins Sauerland Skifahren und ich hab nicht nein gesagt. Ich werde danach in Ruhe das was mir ChatGPT aus euren Vorschlägen zusammengebastelt hat testen und dann mal schauen, wie ich weiterkomme.

Gruß
Christian

AW: eigene Idee

12.01.2026 14:08:33

schauan

Hallo Christian,

also, erst mal ganz allgemein - Du hast ja gemerkt, das Volti und ich bisschen beschrieben haben, dass man unter bestimmten Bedingungen was weglassen kann oder was mehr braucht.
Volti schreibt z.B., dass man bei gleicher Länge der Namen (in der Tabelle) eine Schleife weglassen kann, bei mir ist das eine Voraussetzung.
Wenn die Namen in Deiner Tabelle alle groß geschrieben sind, dann funktioniert von mir die Variante wo irgendwo TRANSPOSE steht. Wenn nicht, muss die Variante mit dem TEXTJOIN genommen werden, usw.

Das A und O (nicht nur) bei der Programmierng ist eine gute Beschreibung der Aufgabe und Bedingungen und darauf aufbauend kann man auch schon ohne VBA den Ablauf beschfreiben.
Nur mal als Beispiel - wenn man beschreibt, wie Laufen funtioniert, reicht es nicht, dass man einen Fuß vor den anderen setzt. Also, zumindest läuft es darauf hinaus, erst den hinteren anheben, nach vorn bringen, absetzen. Dann mit dem anderen ebenso, usw.
Man müsste ggf. noch berücksichtigen, wie viele Beine zur Verfügung stehen, dann wäre der Ablauf ggf. anders ;-)

AW: eigene Idee

12.01.2026 20:47:43

Christian

Hallo Schauan,

und ich dachte beim Eröffnen des Threads, die Aussage, es sollen alle Dateien gelöscht werden, deren Name mit AZN beginnt, aber mit keinem der Texte in Ergebnis!I wäre eindeutig genug, um mein Ziel zu beschreiben. Von solchen Vorschlägen die von Textlänge oder nur Großbuchstaben abhängen, hatte ich da noch keine Ahnung davon.

Was ich sagen kann, die Texte sowie die Dateinamen sind unterschiedlich lang, beginnen alle mit AZN und auf den Text, der in Ergebnis!I steht folgt dann im Dateinamen noch ein Leerzeichen eine laufende Nummer (1 - 3 stellig) und die Dateiendung .jpg

Aber mehr Gemeinsamkeiten fallen mir nicht ein, ok außer dass alle Texte in Ergebnis!I mit AZN beginnnen.

Gruß
Christian

AW: eigene Idee

12.01.2026 21:28:13

schauan

Hi Christian,

alles gut ... Dann hast Du ja von Volti oder ChatGPT Varianten, wo das alles unerheblich ist ;-)

Was man aber sehen kann, ist, dass je nach Voraussetzungen ein unterschiedlicher Programmieraufwand erforderlich ist. Bei größeren Projekten, die man in Auftrag gibt, könnten da schon ein paar Euro mehr oder weniger erforderlich sein. Da kann man abgleichen, ob ein eigener Aufwand - z.B. hier die Großschreibung - einen Mehraufwand bei der Programmierung resp. Mehrausgaben lohnt. Die Großschreibung könnte man schon in der Tabelle per Formel erreichen.
OK, UCASE(...) ist jetzt kein nennenswerter Aufwand ;-)

Übrigens, frage doch ChatGPT mal, ob eine Schleife über Zellen oder die Übernahme der Zellen in ein Array und dann eine Schleife über's Array schneller ist ;-)

AW: eigene Idee

12.01.2026 23:47:42

Christian

Hallo schauan,

ich habe mich nicht an Chatgpt gewandt, um dir oder sonst jemandem der Beteiligten vor den Kopf zu stoßen oder weil ich seine Bemühungen nicht respektiere. Ich habe C. gefragt, weil ich mich überfordet gesehen habe, bei den recht unterschiedlichen Beiträgen alles verstehen zu können, unterscheiden zu können wie sie funktionieren, worauf es hinausläuft und aber auch einschätzen zu können, aus welchem der Vorschläge ich den besten Nutzen ziehe. Dafür fehlen mir einfach die VBA Kenntnisse. Ich hoffe ich habe damit niemanden verärgert, denn ohne eure Hilfe wäre ich nicht so weit wie jetzt und dafür bin ich sehr dankbar.

Deine Frage beantworte ich jetzt mal ohne ChatGPT, ich hoffe ich liege richtig, dass ein Array nicht in Excel sondern im RAM arbeitet und allein deshalb schon schneller ist. Außerdem erspare ich mir für jeden Verarbeitungsschritt dass auf jeden Datensatz in Excel einzeln zugegriffen wird.

Und ChatGPT sagt ich soll dir antworten:

Die Ein-Satz-Antwort fürs Forum 😉

Eine Schleife über ein zuvor geladenes Array ist gegenüber einer Zell-Schleife um Größenordnungen schneller, da Excel-Objektzugriffe vermieden werden.

Oder etwas lockerer:

Alles, was mehr als ein paar Dutzend Zellen betrifft, gehört in ein Array.

Nochmal zu deinen beiden um 19:47 geposteten Vorschlägen, wie ich ja bereits sagte, die Texte sind unterschiedlich lang. Und da kann ich jetzt wieder nur C. zitieren: Für gleichlange, eindeutig identifizierbare Präfixe sind beide Lösungen gut geeignet.
Bei variablen, langen Texten mit vollständigem Abgleich ist ein Dictionary mit exakter Schlüsselprüfung die robustere und schnellere Lösung.

Was soll ich dazu sagen, mir fehlt leider die persönliche Erfahrung, einzuschätzen ob C. da richtig oder falsch liegt.

Gute Nacht
Christian

AW: eigene Idee

12.01.2026 20:47:48

schauan

Hier wären dann mal die beiden Varianten komplett als Sub.
Wie gesagt, die Einträge der Tabelle müssen alle gleich lang sein. Ich habe hier mit 5 programmiert, wenn Du eine andere Länge hast, dann entsprechend ändern ...

Sub Del_1()

    Dim wsErgebnis As Worksheet

    Dim fso As Object, fileObj As Object

    Dim lastErgRow&, arrnot

    'Blatt mit Namen definieren

    Set wsErgebnis = Worksheets("Ergebnis")

    'Filesystemobject setzen

    Set fso = CreateObject("Scripting.FileSystemObject")

    'letzte belegte Zeile in Spalte I fststellen

    lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

    'Daten aus Spalte I in Array uebernehmen, alle Eintraege sind in Grossbuchstaben

    arrnot = WorksheetFunction.Transpose(Range("I1:I" & lastErgRow).Value)

    'Schleife  ueber alle Dateien

    For Each fileObj In fso.GetFolder(folderBilder).Files

         'wenn der Dateiname in Grossbchstaben mit AZN beginnt und keine Uebereinstimmung mit der Liste gefunden wird, dann loeschen

         If UCase(Left(fileObj.Name, 3)) = "AZN" And UBound(Filter(arrnot, Left(fileObj.Name, 5))) Then fso.DeleteFile fileObj.Path, True

    'Ende Schlleife  ueber alle Dateien

    Next fileObj

End Sub

Sub Del_2()

    Dim wsErgebnis As Worksheet

    Dim fso As Object, fileObj As Object

    Dim lastErgRow&, arrnot

    'Blatt mit Namen definieren

    Set wsErgebnis = Worksheets("Ergebnis")

    'Filesystemobject setzen

    Set fso = CreateObject("Scripting.FileSystemObject")

    'letzte belegte Zeile in Spalte I fststellen

    lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

    'Daten aus Spalte I in String uebernehmen und in Grossbuchstaben wandeln

    arrnot = UCase(WorksheetFunction.TextJoin(";", True, Range("I1:I" & lastErgRow).Value))

    'String in Array umwandeln

    arrnot = Split(arrnot, ";")

    'Schlleife  ueber alle Dateien

    For Each fileObj In fso.GetFolder(folderBilder).Files

         'wenn der Dateiname in Grossbchstaben mit AZN beginnt und keine Uebereinstimmung mit der Liste gefunden wird, dann loeschen

         If UCase(Left(fileObj.Name, 3)) = "AZN" And UBound(Filter(arrnot, UCase(Left(fileObj.Name, 5)))) Then fso.DeleteFile fileObj.Path, True

    'Ende Schlleife  ueber alle Dateien

    Next fileObj

End Sub

AW: eigene Idee

12.01.2026 23:29:51

Christian

Hallo schauan,

wie ich ja bereits mehrfach sagte, die Einträge in Ergebnis!I sind nicht gleich lang.

Gruß
Christian

AW: eigene Idee

11.01.2026 19:29:45

Christian

ich muss zugeben, mir fehlt bei euren Vorschlägen teilweise die VBA Kenntnis sie zu verstehen als auch die Einschätzungsfähigkeit, in wie fern sie mir weiterhelfen, daher habe ich mein Problem erneut Chatgpt geschildert (was beim ersten Versuch krachend gescheitert war, bevor ich hier gefragt habe), diesmal aber zusätzlich mit euren Beiträgen.
Diese Suche mit dem letzten Leerzeichen ist möglich, da auf alle Texte aus Ergebnis!I immer ein Leerzeichen, eine laufende Zahl und die Dateiendung folgt.
Herausgekommen ist das hier:

Sub CleanupAZNFiles()



    Dim wsErgebnis As Worksheet

    Dim fso As Object, fileObj As Object

    Dim allowedDict As Object

    Dim ergArr As Variant

    Dim lastErgRow As Long

    Dim i As Long

    Dim baseText As String

    Dim p As Long



    Set wsErgebnis = Worksheets("Ergebnis")

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set allowedDict = CreateObject("Scripting.Dictionary")



    ' --- Ergebnis!I in Dictionary laden ---

    lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

    If lastErgRow > 0 Then

        ergArr = wsErgebnis.Range("I1:I" & lastErgRow).Value

        For i = 1 To UBound(ergArr, 1)

            If Trim(ergArr(i, 1)) > "" Then

                allowedDict(UCase(Trim(ergArr(i, 1)))) = True

            End If

        Next i

    End If



    ' --- Dateien prüfen & löschen ---

    For Each fileObj In fso.GetFolder("D:\Bilder2").Files

        

        If UCase(Left(fileObj.Name, 3)) = "AZN" Then

            

            ' letztes Leerzeichen vor der Nummer suchen

            p = InStrRev(fileObj.Name, " ")

            

            If p > 0 Then

                ' Text ohne " .jpg"

                baseText = Left(fileObj.Name, p - 1)

                

                If Not allowedDict.Exists(UCase(baseText)) Then

                    fso.DeleteFile fileObj.Path, True

                End If

            Else

                ' ungültiger Name → löschen

                fso.DeleteFile fileObj.Path, True

            End If

        End If

    Next fileObj



End Sub

Lösungen mit Filter API oder Regex hat Chatgpt von abgeraten weil entweder zu langsam oder zu riskant (nach ChatGPT Meinung)

AW: Dateilöschmakro beschleunigen

11.01.2026 18:22:42

volti

Hallo Christian,

ob Dein Makro noch zu beschleunigen ist, habe ich nicht geprüft. Stellt sich auch die Frage, wieviel Zeit es benötigt.
Ohne Testdaten kann ich das nicht feststellen.

Hier mal was ganz anderes. Auch hier weiß ich nicht, ob es schneller als Deines ist.

Die API-Funktion listet alle Dateien auf, die Deiner Mustervorgabe entsprechen. Hierbei werden auch alle Unterordner durchsucht. Hoffe, das stört nicht.
Die Mustervorgabe kann neben einem Anfangstext "AZN" z.B. auch die Dateierweiterung mit einschließen.
Wegen der möglichen unterschiedlichen Längen bei den Vorgaben müssen die Checks leider in einer Schleife gemacht werden.
Wenn man sehr viele Vorgaben hat, kann es etwas länger dauern.
Ob dann ein Array oder Dictionary merklich schneller wäre, müsste man dann prüfen und ggf. den code ändern.
Bitte vorsichtig testen. Das Ganze ist natürlich ohne Gewähr :-)

Option Compare Text

Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll" ( _

                ByVal hProcess As LongPtr, ByVal RootPath As LongPtr, _

                ByVal InputPathName As LongPtr, ByVal OutputPathBuffer As LongPtr, _

                ByVal cb As LongPtr, ByVal data As LongPtr) As Long

Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" ( _

                ByVal lpString As LongPtr) As Long

Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" ( _

                ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long

Dim mrSpalte As Range



Private Function CB_EnumDirTree(ByVal lpcwStr As LongPtr, ByVal iNone As Long) As Boolean

  Dim sDatei As String, oItem As Object

  

  sDatei = String(lstrlenW(lpcwStr), 0)         ' Variable mit ausreichend Platz schaffen

  lstrcpyW StrPtr(sDatei), lpcwStr              ' String umkopieren



  For Each oItem In mrSpalte                    ' Auf Vorgaben checken

      If sDatei Like "*\" & oItem.Value & "*" Then Exit Function

  Next oItem

  Kill sDatei                                   ' Datei jetzt löschen

End Function



Sub DateienLoeschen()

  Dim sPfad As String, sDir As String, WSh As Worksheet

  

  sPfad = "C:\Users\volti\Desktop\Downloads" ' Startpfad

  sDir = "AZN*.png"                          ' Dateimaske ggf. ohne .png

  With wsergebnis

     Set mrSpalte = .Range("$I1:$I" & .Cells(.Rows.Count, "I").End(xlUp).Row)

  End With

  EnumDirTreeW 0, StrPtr(sPfad), StrPtr(sDir), 0, AddressOf CB_EnumDirTree, 0

End Sub

Gruß
Karl-Heinz

AW: Dateilöschmakro beschleunigen

12.01.2026 15:07:35

daniel

Hi
mal ein paar kleinigkeiten:

grundsätzlich solltest du schauen, dass du innerhalb der Schleifen (insbesondere bei geschachtelten Schleifen, bei denen sich die Umläufe der inneren Schleife ja vervielfachen) nur das ausführst, was zwingend in der Schleife ausgeführt werden muss, und alles, was sich in der Schleife nicht ändert, dann vor die Schleife ziehst.

da ist z.B. das Dimensionieren der Variable Keep. Vor der Schleife dimensionieren, in der Schleife ggf auf Wert setzen.
Allerdings ist diese Variable überflüssig, du kannst auch anders prüfen, ob die Schleife vorzeitig abgebrochen wurde.

was du noch vorziehen kannst.
du benötigst die Werte im dictinoary allowedDict kleingeschrieben. Mach das gleich beim Einlesen, dann kann das LCASE nachher in der Löschschleife (wo es häufiger ausgeführt wird) entfallen.

If Trim(ergArr(j, 1)) > "" Then allowedDict(LCase(Trim(ergArr(j, 1)))) = 1

gleiches beim Filenamen.
auch den brauchst du in der Schleife häufiger und kleingeschrieben.
Hol dir den Namen in einen Variable und führe die Veränderung hierbei durch.
dann musst du das nur einmal tun und der Zugriff über die Variable sollte auch schneller sein als über die Objekteigenschaften zu gehen:

dim fName as string

...

...

 For Each fileObj In fso.GetFolder(folderBilder).files

        fName = LCase(fileObj.Name)

        If Left(fName, 3) = "azn" Then

            For Each key In allowedDict.Keys

                If Left(fName, Len(key))) = key Then Exit For

            Next key

            If  key is Nothing Then fso.DeleteFile fileObj.Path, True

        End If

    Next fileObj

Gruß Daniel

AW: Dateilöschmakro beschleunigen

13.01.2026 13:39:45

volti

Hallo Christian,

auch wenn das Thema vielleicht schon erledigt ist.....

Mich hat das jetzt doch noch nicht losgelassen und ich habe ein wenig herumprobiert.

Ich denke, man muss hier zwei Dinge unterscheiden.
1. Wie schnell kann auf die zu prüfenden Dateien (bei meinem Test 17.500) zugegriffen werden bei den unterschiedlichen Methoden wie Dir$, FSO, DOS oder eben EnumDirTree.
Die EnumDirTree-Version schränkt ja schon auf die "AZN"-Dateien ein, die man dann ja nicht mehr prüfen muss.
Macht also schon etwas aus, wenn von 100.000 Dateien z.B. nur 10.000 mit "AZN" anfangen.

2. Die Prüfung auf die Vorgaben
Der nur lesende Zugriff auf einen Excelbereich (hier unsere Vorgaben) unterscheidet sich deutlich von schreibenden Aktionen.
Trotzdem reduzierte sich in der Tat durch die Verwendung eines Arrays meine Testzeit deutlich.
Der Test mit Dictionary war noch schneller, aber bei meiner Datenmenge auch nicht ausschlaggebend.

Bei 17.500 Dateien fingen bei meinem Test 450 mit "HR_" an, die auf 30 Vorgaben getestet wurden.
Das dauerte (ohne Löschen der Dateien) 150 ms.

Hier noch mal ein codereduziertes Beispiel mit Dictionary...



Option Compare Text

Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll" (ByVal hProcess As LongPtr, _

                ByVal RootPath As LongPtr, ByVal InputPathName As LongPtr, ByVal OutputPathBuffer As LongPtr, _

                ByVal cb As LongPtr, ByVal data As LongPtr) As Long

Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" ( _

                ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long

Dim allowedDict As Object



Private Function CB_EnumDirTree(ByVal lpcwStr As LongPtr, ByVal iNone As LongPtr) As Boolean

  Dim sDatei As String, vKey As Variant

  

  sDatei = Space(260)                                           ' Variable mit ausreichend Platz schaffen

  lstrcpyW StrPtr(sDatei), lpcwStr                              ' String umkopieren

  For Each vKey In allowedDict.Keys                             ' Prüfung im Dict vornehmen

      If sDatei Like vKey Then Exit Function

  Next vKey

  Kill Left$(sDatei, InStr(sDatei, vbNullChar) - 1)             ' Datei jetzt löschen

End Function



Private Sub DateienLoeschen()

  Dim sPfad As String, sDir As String, i As Long

  

  sPfad = "D:\Pictures"                                         ' Startpfad

  sDir = "HR_*"                                                 ' Dateimaske für Kroatien

  Set allowedDict = CreateObject("Scripting.Dictionary")

 

  With wsergebnis

     For i = 1 To .Cells(.Rows.Count, "I").End(xlUp).Row

         If .Cells(i, "I").Value > "" Then

            allowedDict("*\" & Trim(.Cells(i, "I").Value) & "*") = 1

         End If

     Next i

  End With

  EnumDirTreeW 0, StrPtr(sPfad), StrPtr(sDir), 0, AddressOf CB_EnumDirTree, 0

End Sub

PS: Zum Verständnis dieser Version.
Zentraler Punkt ist hier die API-Funktion EnumDirTreeW.
Der Funktion werden Zeiger auf den Startpfad, die Datei(makse) und die Callbackfunktion übergeben.
Windows ruft nun für jede relevante Datei die Callback auf und übergibt einen Zeiger auf die entsprechende Datei.
Deshalb siehst Du hier auch keine Schleife, in der die Dateinamen bereitgestellt werden.
Der Dateitext muss nun (leider) noch in eine Variable kopiert werden und kann dann entsprechend abgeprüft werden.
Der Dateitext enthält den kompletten Pfad.

Unter Verwendung der anliegenden Datei kannst Du nach Anpassung der Vorgaben ja mal testen, wie lange was benötigt.
https://www.herber.de/bbs/user/180014.xlsb

Gruß
Karl-Heinz

AW: Dateilöschmakro beschleunigen

12.01.2026 21:05:16

Christian

Hallo Daniel,

auch danke für deine Hilfe.
Wie gesagt, auch hier, mangels eigener Erfahrung habe ich auch deinen Vorschlag CHATGPT gezeigt, mit der Bitte, aus allem das Beste rauszuziehen und mir den optimalen Code (nach C. Meinung) zu geben. Durch deinen Beitrag hat C. jetzt

Sorry dass ich da inzwischen C. frage, die eigene Umsetzung und Einordnung all eurer Vorschläge übersteigt leider meine Excel Kenntnisse. Ich kann nagtürlich einen Vorschlag nehmen, Copy + Paste machen und testen, aber das beantwortet mir dann immer noch nicht die Frage, was jetzt der optimale Weg ist. Daher bat ich C. das beste aus euren Vorschlägen rauszuholen.

unnötige Arbeit aus den Schleifen entfernt
String-Operationen vorgezogen
Objektzugriffe minimiert

und es sieht jetzt so aus:

Punkt-für-Punkt: Was wurde konkret geändert?
1️⃣ LCase aus der heißen Schleife entfernt

Vorher (typisch):

If UCase(Left(fileObj.Name, Len(key))) = UCase(key) Then

gesamter Code:

' =====================================================

' 7) AZN Cleanup in D:\Bilder2  (GOLD VERSION)

' =====================================================

Dim allowedDict As Object

Dim ergArr As Variant

Dim fileObj As Object

Dim lastErgRow As Long

Dim j As Long

Dim parts() As String

Dim baseText As String

Dim fName As String



Set allowedDict = CreateObject("Scripting.Dictionary")



' --- 1) erlaubte AZN-Texte aus Ergebnis!I laden (lowercase) ---

lastErgRow = wsErgebnis.Cells(wsErgebnis.Rows.Count, "I").End(xlUp).Row

If lastErgRow >= 1 Then

    ergArr = wsErgebnis.Range("I1:I" & lastErgRow).Value

    For j = 1 To UBound(ergArr, 1)

        If Trim(ergArr(j, 1)) > "" Then

            allowedDict(LCase(Trim(ergArr(j, 1)))) = True

        End If

    Next j

End If



' --- 2) AZN-Dateien prüfen und ggf. löschen ---

For Each fileObj In fso.GetFolder("D:\Bilder2\").Files



    fName = LCase(fileObj.Name)



    ' nur AZN-Dateien anfassen

    If Left(fName, 3) = "azn" Then



        ' Dateiname in Teile zerlegen

        parts = Split(fName, " ")



        ' Basistext = alles vor der laufenden Nummer

        baseText = Join(parts, " ", 0, UBound(parts) - 1)



        ' nicht mehr erlaubt → löschen

        If Not allowedDict.Exists(baseText) Then

            fso.DeleteFile fileObj.Path, True

        End If

    End If

Next fileObj

AW: Dateilöschmakro beschleunigen

11.01.2026 18:37:30

Christian

Hallo Karl-Heinz,

erstmal danke für deine Antwort.
Erstmal bevor ich teste, wir haben spontan ab morgen ein paar Tage Skiurlaub gebucht, ich weiß also nicht, wie häufig ich nächste Woche zum Antworten oder testen kommen werde.

Zu deiner Frage, bei der aktuellen Datenlage und ca. 100 zu löschenden Dateien, braucht der Ursprüngliche Teil des Makros knapp 8 Minuten. Meine eigene Idee konnte ich mangels zu löschenden Dateien im Moment noch nicht ernsthaft testen. Ich weiß da im Moment nicht, wie aussagekräftig das ist, da ein paar Pseudodateien zum Löschen zu erstellen.

Deinen Vorschlag werde ich mir jetzt in Ruhe anschauen und hoffe ihn zu verstehen und testen zu können.

Christian

AW: Dateilöschmakro beschleunigen

11.01.2026 19:04:50

volti

8 Minuten erscheint mir extrem lang.

Ich drück die Daumen, dass der Test erfolgreich ausfällt.

Gruß KH

AW: Dateilöschmakro beschleunigen

11.01.2026 19:58:01

volti

Vielleicht noch ein Tipp:

ggf. kann man mit geschickten Platzhaltern und Suchmasken die Anzahl der Schleifendurchgänge noch reduzieren.

Es sollen z.B. nur die "AZN1*" und die "AZN5*" Dateien berücksichtigt werden:

Such = "AZN[15]*"

Gruß KH

AW: Dateilöschmakro beschleunigen

11.01.2026 20:01:00

Christian

Hallo Karl Heiz auf ANZ folgt immer ein leerzeichen und eine 5stellige Zahl, egal ob es sich um eine Datei zum Löschen oder zum Behalten handelt.

AW: Dateilöschmakro beschleunigen

12.01.2026 11:52:06

volti

Hallo Christian,

wenn es doch eine feste Länge bei den Dateien und Vorgaben gibt, kann die Schleife ja entfallen.
Hier ein neuer Vorschlag...

Option Compare Text

Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll" ( _

                ByVal hProcess As LongPtr, ByVal RootPath As LongPtr, _

                ByVal InputPathName As LongPtr, ByVal OutputPathBuffer As LongPtr, _

                ByVal cb As LongPtr, ByVal data As LongPtr) As Long

Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" ( _

                ByVal lpString As LongPtr) As Long

Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" ( _

                ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long

Dim mrSpalte As Range



Private Function CB_EnumDirTree(ByVal lpcwStr As LongPtr, ByVal iNone As Long) As Boolean

  Dim sDatei As String, sSuch As String, i As Long

  

  sDatei = String(lstrlenW(lpcwStr), 0)         ' Variable mit ausreichend Platz schaffen

  lstrcpyW StrPtr(sDatei), lpcwStr              ' String umkopieren



  On Error Resume Next

  sSuch = Split(Mid$(sDatei, InStrRev(sDatei, "\") + 1), ".")(0)

  i = Application.WorksheetFunction.Match(sSuch, wsergebnis.Range("I:I"), 0)

  If i = 0 Then Kill sDatei                     ' Datei jetzt löschen

End Function



Sub DateienLoeschen()

  Dim sPfad As String, sDir As String

  

  sPfad = "C:\Users\voltm\Desktop\Ahnentafel\Downloads" ' Startpfad

  sDir = "AZN *"                                ' Dateimaske

  EnumDirTreeW 0, StrPtr(sPfad), StrPtr(sDir), 0, AddressOf CB_EnumDirTree, 0

End Sub

Aber nun erst mal viel Spaß im Sauerland. Winterberg?

Dort in der Nähe habe ich auch mal ein paar Jahr gewohnt. Da gab es noch viel Schnee....

Gruß
KH

AW: Dateilöschmakro beschleunigen

12.01.2026 11:57:37

volti

Nachtrag...

Man kann hier die Beiträge ja nicht mehr ändern.

 sSuch = Left$(Mid$(sDatei, InStrRev(sDatei, "\") + 1), 9)

Gruß KH

AW: Dateilöschmakro beschleunigen

12.01.2026 20:51:01

Christian

Ja, Winterberg, aber Nebel, Niselregen, warte erstmal ob das Wetter noch besser wird, bevor ich auf die Piste gehe, so macht das ja auch keinen Spaß.

Wie ich eben schon schauan sagte, die Dateinamen sind unterschiedlich lang, die einzigen Gemeinsamkeiten sind, dass alle Texte in Ergebnis mit AZN beginnen und bei den Dateinamen nach den Texten aus Ergebnis noch ein Leerzeichen, eine laufende Nummer (1-3 stellig) sowie .jpg folgt.

Gruß
Christian

Dateilöschmakro beschleunigen

Forumthread: Dateilöschmakro beschleunigen

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Dateilöschmakro beschleunigen

Forumthread: Dateilöschmakro beschleunigen

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread