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