Hallo Wolfgang,
das nach der Linie in ein Modul im Excel kopieren.
Mit der Function START, werden deine Dateien gesucht und in Spalte A, im Excel, aufgeschrieben.
In Spalte B wird der neue Pfad ohne den Ordner Video aufgeschrieben.
Mit der Function Start_umbennen änders du die Dateien ab. Diese werden jetzt verschoben.
(Ein Function kannst du mit F5 starten. Achtung! Vorher in die zu funktion klicken.)
Bevor du die Dateien verschiebst, schau den Pfad in Spalte B an, damit der auch passt.
Alle_Daten = S_Dateisuche("S:\TEMP\", "*.avi") --> hier musst du anpassen, welche dateien gesucht werden sollen und in
welchen Ordner alles liegt..
avi.. mkv usw.
Die VIDEO Ordner könntest du im anschluss auch über die Windowssuche löschen.
Oder man schreibt noch nen code, der leere Ordner löscht...
__________________________________________________________________________
Option Explicit
Dim DateinamenFeld() As Variant
Dim DateinamenZähler As Long
Dim DateinamenLast As String
Function START()
Dim Alle_Daten As Variant
Dim L As Long
Application.ScreenUpdating = False
Alle_Daten = S_Dateisuche("S:\TEMP\", "*.avi")
With ActiveSheet
on error resume next
For L = 1 To UBound(Alle_Daten)
.Range("A" & L) = Alle_Daten(L)
.Range("B" & L) = Replace(Alle_Daten(L), "\VIDEO", "")
Next L
on error goto 0
End With
Application.ScreenUpdating = True
MsgBox "fertig"
End Function
Function Start_umbennen()
Dim L As Long
Dim LZ As Long
Dim Namealt As String
Dim Nameneu As String
Application.ScreenUpdating = False
With ActiveSheet
LZ = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
For L = 1 To LZ
Namealt = .Range("A" & L)
Nameneu = .Range("B" & L)
Name Namealt As Nameneu
Next L
End With
Application.ScreenUpdating = True
MsgBox "fertig"
End Function
Function S_Dateisuche(Ordnerpfad As String, Dateiname_Endung As String) As Variant
DateinamenZähler = 0
Erase DateinamenFeld
If Dir(Ordnerpfad, vbDirectory) <> "" Then
Dateisuche Ordnerpfad, Dateiname_Endung
Schreiben Ordnerpfad
S_Dateisuche = DateinamenFeld
Else
ReDim DateinamenFeld(0)
DateinamenFeld(0) = ""
S_Dateisuche = DateinamenFeld
End If
End Function
Private Function Dateisuche(Ordnerpfad As String, Dateiname_Endung As String)
Dim Dateiname As String
DateinamenLast = Dateiname_Endung
If Right(Ordnerpfad, 1) <> "\" Then Ordnerpfad = Ordnerpfad & "\"
Dateiname = Dir(Ordnerpfad & Dateiname_Endung)
Do Until Dateiname = ""
DoEvents
ReDim Preserve DateinamenFeld(DateinamenZähler)
DateinamenFeld(DateinamenZähler) = Ordnerpfad & Dateiname
DateinamenZähler = DateinamenZähler + 1
Dateiname = Dir
Loop
End Function
Private Function Schreiben(Suchordner)
Dim FSO As Object
Dim Ordner
Dim Unterordner
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Ordner = FSO.GetFolder(Suchordner)
On Error Resume Next
For Each Unterordner In Ordner.SubFolders
DoEvents
Dateisuche Unterordner.Path, DateinamenLast
Schreiben Unterordner
Next
Set FSO = Nothing
Set Ordner = Nothing
End Function
|