Hallo Forumsmitglieder,

Habe einen Code der mir aus Netzwerkordner nur die doppelten Dateien in Excel einlesen soll.

Habe zwar die doppelten aber auch die unikate werden eingelesen, komme nicht darauf warum.

Kann jemand von euch da mal darauf schauen.

Option Explicit
Sub ReadFilesAndFilterDuplicates()
Dim strPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim wsDup As Worksheet
Dim fileNameList As Object
Dim iRowDup As Long

' Dialogfeld zum Öffnen eines Netzwerkordners anzeigen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Netzwerkordner auswählen doppelte Dateien"
If .Show = -1 Then
strPath = .SelectedItems(1)
Else
Exit Sub
End If
End With

' Objekte erstellen und initialisieren
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPath)
Set fileNameList = CreateObject("Scripting.Dictionary")

' Neues Tabellenblatt für Duplikate erstellen
Set wsDup = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsDup.Name = "Duplikate_" & Format(Now(), "dd_mm_yyyy_hh_mm_ss")

' Überschriften einfügen
wsDup.Range("A1").Value = "Dateiname"
wsDup.Range("B1").Value = "Dateiverzeichnis"
wsDup.Range("C1").Value = "Erstelldatum"
wsDup.Range("D1").Value = "Änderungsdatum"
wsDup.Range("E1").Value = "Eingelesen am"
wsDup.Range("F1").Value = "Grösse in KB"
wsDup.Range("G1").Value = "Letzter Zugriff"
wsDup.Range("H1").Value = "Löschen mit x"
wsDup.Range("I1").Value = "Alter"
wsDup.Range("J1").Value = "Dateityp"

' Überschriften formatieren
wsDup.Range("A1:J1").Font.Bold = True

iRowDup = 2
Application.StatusBar = "Einlesen des Verzeichnisses läuft. Bitte warten..."

' Schleife für Dateien im Hauptverzeichnis durchführen
Dim objFile As Object
For Each objFile In objFolder.Files
ProcessFile objFile, objFSO, wsDup, fileNameList, iRowDup
Next objFile

' Schleife für Dateien in Unterordnern durchführen
ReadFilesAndFilterByDateAndCopyDuplicates objFSO, objFolder, iRowDup, wsDup, fileNameList

Application.StatusBar = False

' Entferne leere Zeilen in der Tabelle "Duplikate"
RemoveEmptyRows wsDup

' Tabellenblatt "Duplikate" formatieren
wsDup.Columns("A:G").AutoFit
wsDup.Columns("C:E").NumberFormat = "dd.mm.yyyy hh:mm:ss"
wsDup.Columns("F:F").NumberFormat = "0.00"
wsDup.Columns("H:H").ColumnWidth = 14
wsDup.Columns("H").HorizontalAlignment = xlCenter
wsDup.Columns("H").Font.Color = RGB(255, 0, 0)
wsDup.Rows("1:1").AutoFilter

' Spalte I (Alter) mit Textausgabe füllen
FillColumnWithAgeInfo wsDup

' Spalte J (Dateityp) mit Dateityp füllen
FillColumnWithFileTypes wsDup

MsgBox "Verzeichnis erfolgreich eingelesen.", vbInformation, "Einlesen abgeschlossen"
End Sub
Sub ProcessFile(ByVal objFile As Object, ByVal objFSO As Object, ByVal wsDup As Worksheet, ByRef fileNameList As Object, ByRef iRowDup As Long)
Dim fileSizeKB As Double
Dim fileCreateDate As Date
Dim fileModifyDate As Date
Dim fileLastAccessDate As Date

' Dateiinformationen abrufen
fileSizeKB = objFile.Size / 1024 ' Größe in KB umrechnen
fileCreateDate = objFile.DateCreated
fileModifyDate = objFile.DateLastModified
fileLastAccessDate = objFile.DateLastAccessed

' Überprüfen, ob die Datei bereits in der Liste vorhanden ist
If FileNameExistsInList(fileNameList, objFile.Name) Then
' Datei ist doppelt, in wsDup einfügen
wsDup.Cells(iRowDup, 1).Value = objFile.Name
wsDup.Hyperlinks.Add _
Anchor:=wsDup.Cells(iRowDup, 1), _
Address:=objFile.Path, _
TextToDisplay:=objFile.Name ' Hyperlink erstellen

wsDup.Cells(iRowDup, 2).Value = objFSO.GetParentFolderName(objFile.Path)
wsDup.Cells(iRowDup, 3).Value = fileCreateDate
wsDup.Cells(iRowDup, 4).Value = fileModifyDate
wsDup.Cells(iRowDup, 5).Value = Format(Now(), "dd.mm.yyyy hh:mm:ss")
wsDup.Cells(iRowDup, 6).Value = fileSizeKB / 1024
wsDup.Cells(iRowDup, 7).Value = fileLastAccessDate

' Dropdown-Feld für Löschen mit x hinzufügen
With wsDup.Cells(iRowDup, 8).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="x"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With

iRowDup = iRowDup + 1
Else
' Wenn der Dateiname nicht in der Liste vorhanden ist, füge ihn der Liste hinzu
fileNameList.Add objFile.Name, 0
End If
End Sub
Sub ReadFilesAndFilterByDateAndCopyDuplicates(ByVal objFSO As Object, ByVal objFolder As Object, ByRef iRowDup As Long, ByVal wsDup As Worksheet, ByRef fileNameList As Object)
Dim objFile As Object
Dim fileSizeKB As Double
Dim fileCreateDate As Date
Dim fileModifyDate As Date
Dim fileLastAccessDate As Date
Dim subFolder As Object ' Variable für Unterordner definieren

' Schleife für alle Dateien im aktuellen Ordner durchführen
For Each objFile In objFolder.Files
' Dateiinformationen abrufen
fileSizeKB = objFile.Size / 1024 ' Größe in KB umrechnen
fileCreateDate = objFile.DateCreated
fileModifyDate = objFile.DateLastModified
fileLastAccessDate = objFile.DateLastAccessed

' Überprüfen, ob die Datei bereits in der Liste vorhanden ist
If FileNameExistsInList(fileNameList, objFile.Name) Then
' Datei ist doppelt, in wsDup einfügen
wsDup.Cells(iRowDup, 1).Value = objFile.Name
wsDup.Hyperlinks.Add _
Anchor:=wsDup.Cells(iRowDup, 1), _
Address:=objFile.Path, _
TextToDisplay:=objFile.Name ' Hyperlink erstellen

wsDup.Cells(iRowDup, 2).Value = objFSO.GetParentFolderName(objFile.Path)
wsDup.Cells(iRowDup, 3).Value = fileCreateDate
wsDup.Cells(iRowDup, 4).Value = fileModifyDate
wsDup.Cells(iRowDup, 5).Value = Format(Now(), "dd.mm.yyyy hh:mm:ss")
wsDup.Cells(iRowDup, 6).Value = fileSizeKB / 1024
wsDup.Cells(iRowDup, 7).Value = fileLastAccessDate

' Dropdown-Feld für Löschen mit x hinzufügen
With wsDup.Cells(iRowDup, 8).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="x"
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With

iRowDup = iRowDup + 1
Else
' Wenn der Dateiname nicht in der Liste vorhanden ist, füge ihn der Liste hinzu
fileNameList.Add objFile.Name, 0
End If
Next objFile

' Schleife für alle Unterordner durchführen
On Error Resume Next ' Fehlerbehandlung aktivieren
For Each subFolder In objFolder.SubFolders
ReadFilesAndFilterByDateAndCopyDuplicates objFSO, subFolder, iRowDup, wsDup, fileNameList
Next subFolder
On Error GoTo 0 ' Fehlerbehandlung ausschalten
End Sub

Function FileNameExistsInList(ByRef fileNameList As Object, ByVal fileName As String) As Boolean
On Error Resume Next
FileNameExistsInList = fileNameList.Exists(fileName)
On Error GoTo 0
End Function

Sub RemoveEmptyRows(ByVal ws As Worksheet)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' Schleife zum Löschen der leeren Zeilen
If lastRow > 1 Then
Dim I As Long
For I = lastRow To 2 Step -1
If ws.Cells(I, 1).Value = "" Then
ws.Rows(I).EntireRow.Delete
End If
Next I
End If
End Sub
Sub FillColumnWithAgeInfo(ByVal ws As Worksheet)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' Schleife zum Befüllen der Spalte I (Alter)
If lastRow > 1 Then
Dim I As Long
For I = 2 To lastRow
Dim modifyDate As Date
modifyDate = ws.Cells(I, 4).Value
If modifyDate DateAdd("yyyy", -11, Date) Then
ws.Cells(I, 9).Value = "> 11 Jahre"
ElseIf modifyDate DateAdd("yyyy", -2, Date) Then
ws.Cells(I, 9).Value = "> 2 Jahre"
Else
ws.Cells(I, 9).Value = ""
End If
Next I
End If
End Sub
Sub FillColumnWithFileTypes(ByVal ws As Worksheet)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

' Schleife zum Befüllen der Spalte J (Dateityp)
If lastRow > 1 Then
Dim I As Long
For I = 2 To lastRow
ws.Cells(I, 10).Value = Right(ws.Cells(I, 1).Value, Len(ws.Cells(I, 1).Value) - InStrRev(ws.Cells(I, 1).Value, "."))
Next I
End If
End Sub