Änderung eines Scripts.Dateien automatisch verschieben.

Option Explicit

Const FilePath = "E:\Test"  
Const MovePath = "E:\Test\Move"  

Const FileType = "txt"  

Const Delim = "-"  

Const Err1 = "Der Ordner FilePath existiert nicht!"  
Const Err2 = "Der Ordner existiert nicht: %1\%2-*\%3"  

Dim Fso, File, Folder, Path, Token, Msg

'Import der Bibliothek für Datei-System-Funktionen  
 Set Fso = CreateObject("Scripting.FileSystemObject")  

'Prüfen ob der Pfad in der Konstanten FilePath existiert  
 If Fso.FolderExists(FilePath) = False Then
    
    'Wenn der Pfad nicht existiert, dann Fehlermeldung ausgeben und Script abbrechen  
     MsgBox Err1, vbExclamation, "Fehler": WScript.Quit  
 End If

'Alle Dateien im Pfad FilePath einlesen  
 For Each File In Fso.GetFolder(FilePath).Files
    
    'Prüften ob die Dateierweiterung FileType entspricht  
     If LCase(Fso.GetExtensionName(File.Name)) = LCase(FileType) Then
        
        'Dateinamen mit dem Trennzeichen Delim in Einzelteile zerlegen  
         Token = Split(Fso.GetBaseName(File.Name), Delim)
        
        'Test ob Dateinamen mindestens 2 Trennzeichen enthält  
         If UBound(Token) >= 1 Then
            
            'Wenn Ja, dann Funktionsaufruf MovePath ermitteln  
             Path = GetPath(Token)
            
            'Prüfen ob der Ordner-Pfad existiert  
             If Path = "" Then  
                
                'Wenn Nein, dann die Meldung mit dem nicht gefundenem Pfad erstellen  
                 Msg = Replace(Replace(Replace(Err2, "%1", MovePath), "%2", Token(0)), "%3", Token(1))  
                
                'Meldung ausgeben  
                 MsgBox Msg, vbInformation, "Meldung"  
             Else
                'Prüfen ob die Datei bereits existiert, gegebenenfalls löschen  
                 If Fso.FileExists(Path & File.Name) Then Fso.DeleteFile Path & File.Name
                
                'Wenn OK, dann Datei verschieben  
                 Fso.MoveFile File, Path             End If
         End If
     End If

'Nächste Datei einlesen  
 Next

 MsgBox "Fertig!"  

Function GetPath(ByRef Token)
    Dim Folder, SubFolder
  
    'Rückgabewert mit Leerstring initialisieren  
    GetPath = ""  
    
    'Alle Ordner im Pfad MovePath einlesen  
    For Each Folder In Fso.GetFolder(MovePath).SubFolders
    
        'Prüfen ob der Ordnername das 1. Token + Trennzeichen enthält  
        If Left(Folder.Name, Len(Token(0)) + 1) = Token(0) & "-" Then  
        
           'Wenn Ja, dann die Unterordner des aktuellen Ordners einlesen  
            For Each SubFolder In Fso.GetFolder(Folder).SubFolders
                
               'Prüfen ob der Unter-Ordnername das 2. Token enthält  
                If Left(SubFolder.Name, Len(Token(1))) = Token(1) Then
                
                   'Wenn Ja, dann Pfad zurückgeben und Schleife beenden  
                    GetPath = SubFolder & "\":  Exit For  
                End If
            
           'Nächsten Unterordner einlesen  
            Next
            
           'Wenn Ordner gefunden, dann Scheife vorzeitig beenden  
            Exit For
        End If
    
   'Nächsten Ordner einlesen  
    Next
End Function

If Left(SubFolder.Name, Len(Token(1))) = Token(1) Then GetPath = SubFolder & "\" :  Exit For  

If Left(SubFolder.Name, Len(Token(1))) = Token(1) Then GetPath = SubFolder & "\"  
Exit For

Option Explicit

Const LogFile = "Move.Log"  
Const FilePath = "E:\Threads\138258\Test"  
Const MovePath = "E:\Threads\138258\Test\Move"  

Const FileType = "txt"  

Const Delim = "-"  

Const Err1 = "Der Ordner FilePath existiert nicht!"  
Const Err2 = "Folgende Ordner existieren nicht:"  

Dim Shell, Fso, File, Folder, Path, Token, Log, LogPath

'Import der Bibliothek für Datei-System-Funktionen  
 Set Fso = CreateObject("Scripting.FileSystemObject")  

'Import der Bibliothek für Shell-Funktionen  
 Set Shell = CreateObject("WScript.Shell")  

'Prüfen ob der Pfad in der Konstanten FilePath existiert  
 If Fso.FolderExists(FilePath) = False Then
    
    'Wenn der Pfad nicht existiert, dann Fehlermeldung ausgeben und Script abbrechen  
     MsgBox Err1, vbExclamation, "Fehler": WScript.Quit  
 End If

'Variable mit dem Pfad der Log-Datei  
 LogPath = FilePath & "\" & LogFile  

'Log-Datei erstellen  
 Set Log = Fso.CreateTextFile(LogPath)

'Text mit aktuellem Datum und Zeit in Log-Datei schreiben  
 Log.WriteLine "Erstellt: " & Now & vbCrLf & vbCrLf & Err2  

'Alle Dateien im Pfad FilePath einlesen  
 For Each File In Fso.GetFolder(FilePath).Files
    
    'Prüften ob die Dateierweiterung FileType entspricht  
     If LCase(Fso.GetExtensionName(File.Name)) = LCase(FileType) Then
        
        'Dateinamen mit dem Trennzeichen Delim in Einzelteile zerlegen  
         Token = Split(Fso.GetBaseName(File.Name), Delim)
        
        'Test ob Dateinamen mindestens 2 Trennzeichen enthält  
         If UBound(Token) >= 1 Then
            
            'Wenn Ja, dann Funktionsaufruf MovePath ermitteln  
             Path = GetPath(Token) & "\"  
            
            'Prüfen ob der Ordner-Pfad existiert  
             If Path = "\" Then  
                
                'Wenn Nein, dann fehlenden Pfad in Log-Datei schreiben  
                 Log.WriteLine MovePath & "\" & Token(0) & "-*\" & Token(1)  
             Else
                'Prüfen ob die Datei bereits existiert, gegebenenfalls löschen  
                 If Fso.FileExists(Path & File.Name) Then Fso.DeleteFile Path & File.Name
                
                'Wenn OK, dann Datei verschieben  
                 Fso.MoveFile File, Path
             End If
         End If
     End If

'Nächste Datei einlesen  
 Next

'Log-Datei schließen  
 Log.Close

'Log-Datei im Notpad-Editor anzeigen  
 Shell.Run "Notepad " & """" & LogPath & """"  

Function GetPath(ByRef Token)
    Dim Folder, SubFolder
  
    'Rückgabewert mit Leerstring initialisieren  
    GetPath = ""  
    
    'Alle Ordner im Pfad MovePath einlesen  
    For Each Folder In Fso.GetFolder(MovePath).SubFolders
    
        'Prüfen ob der Ordnername das 1. Token + Trennzeichen enthält  
        If Left(Folder.Name, Len(Token(0)) + 1) = Token(0) & "-" Then  
        
           'Wenn Ja, dann die Unterordner des aktuellen Ordners einlesen  
            For Each SubFolder In Fso.GetFolder(Folder).SubFolders
                
               'Prüfen ob der Unter-Ordnername das 2. Token enthält  
                If Left(SubFolder.Name, Len(Token(1))) = Token(1) Then
                
                   'Wenn Ja, dann Pfad zurückgeben und Schleife beenden  
                    GetPath = SubFolder:  Exit For
                End If
            
           'Nächsten Unterordner einlesen  
            Next
            
           'Prüfen ob Unterordner gefunden wurde. Wenn Nein Unterordner erstellen  
            If GetPath = "" Then GetPath = Fso.CreateFolder(Folder & "\" & Token(1))  
           
           'Wenn Haupt-Ordner gefunden, dann Scheife vorzeitig beenden  
            Exit For
        End If
    
   'Nächsten Ordner einlesen  
    Next
End Function