Bilder aus Ordner löschen

Hallo zusammen
Ich habe in den Zellen A1 bis A536 Namen von Bildern (alles .jpg) stehen. Im Ordner 'Bilder' hat es aber 1200 Bilder. Ich möchte nun alle Bilder löschen, die nicht in der Excel-Datei stehen, als so dass am Schluss nur noch die 536 Bilder aus der Liste vorhanden sind. Das nachstehende Makro habe ich hier gefunden, nur läuft da ewig die Sanduhr und nichts wird gelöscht oder dann werden gleich alle Bilder gelöscht(!). Ein Neustart vom PC und Deaktivieren vom Virenscanner bringt auch keine Abhilfe.
Die Excel-Datei liegt im gleichen Verzeichnis wie die Bilder und das WS heisst 'Bilder'.
Weiss jemand wo der Fehler liegt oder hat jemand ein anderes Makro das ich ausprobieren könnte?
Vielen Dank!
Grüsse
Patrick


Sub JPG_loeschen()
'Die Bildnamen müssen in einer Tabelle mit Namen "Bilder" in Spalte A stehen.
'Bildnamen ohne Pfadangabe, z.B. Test.jpg _
Wenn die Bildnamen mit komplettem Pfad angegeben sind, einfach die Zuweisung _
der Variablen strName ändern: strName=.FoundFiles(i)
'Diese Datei muss im gleichen Ordner wie die Bilder stehen.
'Unterordner werden nicht durchsucht.
Dim wshBilder As Worksheet, _
strOrdner As String, _
strName As String, _
fs As FileSearch, _
i As Integer, _
n As Integer, _
bolGebraucht As Boolean
Application.ScreenUpdating = False
Set wshBilder = Worksheets("Bilder") 'Tabelle mit Bildnamen
strOrdner = ThisWorkbook.Path
Set fs = Application.FileSearch
'Dateien suchen
With fs
.LookIn = strOrdner
.Filename = "*.jpg" 'Dateityp jpg
.SearchSubFolders = False 'keine Unterordner durchsuchen
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
bolGebraucht = False
strName = Right(.FoundFiles(i), Len(.FoundFiles(i)) - Len(strOrdner) - 1)
'gefundene Datei mit Liste vergleichen
For n = 1 To wshBilder.Range("A:A").End(xlUp).Row
If UCase(wshBilder.Cells(n, 1)) = UCase(strName) Then
bolGebraucht = True 'Datei steht in Liste
Exit For
End If
Next n
'Wenn Datei nicht in Liste, dann löschen
If bolGebraucht = False Then
Kill .FoundFiles(i)
End If
Next i
End If
End With
Application.ScreenUpdating = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Patrick!
Probier diesen Code.
Es spielt keine Rolle, ob in den Zellen z.B. "test", "test.jpg" oder "C:\Ordner\test.jpg" steht!

Sub JPG_loeschen()
Dim wshBilder As Worksheet
Dim strOrdner As String
Dim intIndex As Integer
Dim vFiles() As Variant, vNames As Variant, vName() As Variant
Dim objFS As FileSearch
Dim objFSO As Object

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set wshBilder = Worksheets("Bilder") 'Tabelle mit Bildnamen

Set objFS = Application.FileSearch

strOrdner = ThisWorkbook.Path

vNames = wshBilder.Range("A1:A" & wshBilder.Cells(Rows.Count, 1).End(xlUp).Row)

Redim vName(1 To UBound(vNames, 1))

For intIndex = 1 To UBound(vNames, 1)
  vName(intIndex) = objFSO.getbasename(vNames(intIndex, 1))
Next

'Dateien suchen
With objFS

  .LookIn = strOrdner
  .Filename = "*.jpg" 'Dateityp jpg
  .SearchSubFolders = False 'keine Unterordner durchsuchen

  If .Execute > 0 Then

    Redim vFiles(1 To .FoundFiles.Count)

    For intIndex = 1 To .FoundFiles.Count
      vFiles(intIndex) = objFSO.getbasename(.FoundFiles(intIndex))
    Next

    For intIndex = 1 To UBound(vFiles)
      If Not IsNumeric(Application.Match(vFiles(intIndex), vName, 0)) Then
        Kill .FoundFiles(intIndex)
      End If
    Next

  End If

End With

Set wshBilder = Nothing
Set objFSO = Nothing
Set objFS = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread