Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1952to1956
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Änderungsdatum und gleiche Dateigrösse behalten

Änderungsdatum und gleiche Dateigrösse behalten
16.11.2023 10:27:07
marcus
Hallo liebe Forumsmitlieder,

ich habe in einer Tabelle Dateien aus einen verzeichnis eingesesen.

Danach soll in der Spalte D Änderungsdatum die gleich sind und Spalte F Dateigrösse die gleich sind in der Liste beibehalten werden, wärend alle anderen aus der Tabelle gelöscht werden sollen.

Dieser Code funktioniert nur bedingt, kann sich das von euch jemand anschauen

Sub Vergleich()
Dim wksListe As Worksheet
Set wksListe = tbl_DuplikateEinlesen ' Name der Tabelle anpassen

Dim lastRow As Long
lastRow = wksListe.Cells(wksListe.Rows.Count, "A").End(xlUp).Row ' Annahme: Daten beginnen in Spalte A

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Dim i As Long
For i = 2 To lastRow ' Annahme: Die Überschrift ist in Zeile 1, und die Daten beginnen in Zeile 2
Dim fileName As String
Dim modifyDate As Date
Dim fileSize As Double

fileName = wksListe.Cells(i, 1).Value ' Annahme: Dateiname in Spalte A
modifyDate = wksListe.Cells(i, 4).Value ' Annahme: Änderungsdatum in Spalte D
fileSize = wksListe.Cells(i, 6).Value ' Annahme: Dateigröße in Spalte F

' Wenn Datei bereits im Dictionary ist, überprüfe auf Duplikat
If dict.Exists(fileName) Then
' Vergleich des Änderungsdatums und der Dateigröße
If fileSize = dict(fileName)("Size") And CDate(modifyDate) = CDate(dict(fileName)("Date")) Then
' Als behalten markieren, da gleiche Änderungsdatum und Dateigröße
dict(fileName)("Behalten") = True
End If
Else
' Hinzufügen der Datei und der Daten zum Dictionary
Set dict(fileName) = CreateObject("Scripting.Dictionary")
dict(fileName)("Date") = modifyDate
dict(fileName)("Size") = fileSize
dict(fileName)("Behalten") = False
End If
Next i

' Entferne die markierten Duplikate
For i = lastRow To 2 Step -1
If Not dict(wksListe.Cells(i, 1).Value)("Behalten") Then
wksListe.Rows(i).Delete
End If
Next i
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Änderungsdatum und gleiche Dateigrösse behalten gelöst
16.11.2023 11:04:02
marcus
Habe einen anderen ansatz probiert dieser Funktioniert auch, trotzdem Danke!

Sub VergleichDatumGroesse()
Dim wksListe As Worksheet
Set wksListe = tbl_DuplikateEinlesen ' Name der Tabelle anpassen

Dim lastRow As Long
lastRow = wksListe.Cells(wksListe.Rows.Count, "A").End(xlUp).Row ' Annahme: Daten beginnen in Spalte A

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

Dim i As Long
For i = 2 To lastRow ' Annahme: Die Überschrift ist in Zeile 1, und die Daten beginnen in Zeile 2
Dim fileName As String
Dim modifyDate As Date
Dim fileSize As Double

' Extrahiere den Dateinamen ohne Pfad
fileName = Mid(wksListe.Cells(i, 1).Formula, InStrRev(wksListe.Cells(i, 1).Formula, "\") + 1)
modifyDate = wksListe.Cells(i, 4).Value ' Annahme: Änderungsdatum in Spalte D
fileSize = wksListe.Cells(i, 6).Value ' Annahme: Dateigröße in Spalte F

' Verwende eine Kombination aus Dateiname, Änderungsdatum und Größe als Schlüssel
Dim key As String
key = fileName & "_" & Format(modifyDate, "dd.mm.yyyy hh:mm:ss") & "_" & Format(fileSize, "0.000000")

' Wenn der Schlüssel bereits im Dictionary ist, als behalten markieren
If dict.Exists(key) Then
dict(key) = True
Else
' Hinzufügen des Schlüssels zum Dictionary
dict.Add key, False
End If
Next i

' Entferne die markierten Duplikate
For i = lastRow To 2 Step -1
Dim keyToDelete As String
keyToDelete = Mid(wksListe.Cells(i, 1).Formula, InStrRev(wksListe.Cells(i, 1).Formula, "\") + 1) & "_" & _
Format(wksListe.Cells(i, 4).Value, "dd.mm.yyyy hh:mm:ss") & "_" & _
Format(wksListe.Cells(i, 6).Value, "0.000000")

If dict.Exists(keyToDelete) Then
If Not dict(keyToDelete) Then
wksListe.Rows(i).Delete
End If
End If
Next i
End Sub
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige