AW: Teile von Dateinamen löschen
23.05.2025 16:41:24
daniel
Hi
probiere mal folgendes Makro:
dieses Makro fügst du in eine neue leere Mappe ein
in die Zelle A1 des ersten Tabellenblatts schreibst du dann das Startverzeichnis, welches durchsucht werden soll.
der Rest des Blattes sollte leer sein.
Dann startetst du dieses Makro
der erste Teil schreibt alle infrage kommenden Dateien mit Verzeichnis in die Spalte C und D
dabei werden alle Unterverzeichnisse berücksichtigt.
der zweite Teil führt dann die Bearbeitung durch.
die Liste wird nach Namen sortiert. der Name mit der höchsten Numerierung wird dann umbenannt, die anderen werden gelöscht.
Sub Dateien_überarbeiten()
ReDim vz(0) As String
Dim Dat As String
Dim v As Long
Dim Zelle As Range
vz(0) = ThisWorkbook.Sheets(1).Cells(1, 1).Value
If Right(vz(0), 1) > "\" Then vz(0) = vz(0) & "\"
ThisWorkbook.Sheets(1).Columns("B:E").ClearContents
v = 0
Do Until v > UBound(vz)
Dat = Dir(vz(v) & "*", vbDirectory)
Do Until Dat = ""
If Dat = "." Or Dat = ".." Then
ElseIf (GetAttr(vz(v) & Dat) And vbDirectory) = vbDirectory Then
ReDim Preserve vz(UBound(vz) + 1)
vz(UBound(vz)) = vz(v) & Dat & "\"
ElseIf Dat Like "*_###.pdf" Then
With ThisWorkbook.Sheets(1).Cells(Rows.Count, 3).End(xlUp)
.Offset(1, 0) = vz(v)
.Offset(1, 1) = Dat
End With
Else
End If
Dat = Dir
Loop
v = v + 1
Loop
With ThisWorkbook.Sheets(1)
If .Cells(2, 3).Value > "" Then
With .Cells(2, 3).CurrentRegion
.Sort key1:=.Cells(1, 2), order1:=xlAscending, Header:=xlNo
For Each Zelle In .Columns(2).Cells
If Left(Zelle.Value, Len(Zelle.Value) - 8) = Left(Zelle.Offset(1, 0).Value, WorksheetFunction.Max(0, Len(Zelle.Offset(1, 0).Value) - 8)) Then
Kill Zelle.Offset(0, -1).Value & Zelle.Value
Else
Name Zelle.Offset(0, -1).Value & Zelle.Value As Zelle.Offset(0, -1).Value & Left(Zelle.Value, Len(Zelle.Value) - 8) & Right(Zelle.Value, 4)
End If
Zelle.Offset(0, -1).Resize(, 2).ClearContents
Next
End With
End If
End With
End Sub
Gruß Daniel