Option Explicit
Dim DateiSystem, Datei, Pfad, Erstellt, Jahr, Monat, Tag
 
Set DateiSystem = CreateObject("Scripting.FileSystemObject")
 
For Each Datei In DateiSystem.GetFolder("D:\").Files
  Erstellt = Datei.DateCreated
  Jahr = Year(Erstellt)
  Monat = MonthName(Month(Erstellt))
  Tag = Day(Erstellt)
 
  Pfad = "D:\" & Jahr
  CheckFolder(Pfad)
  Pfad = Pfad & "\" & Monat
  CheckFolder(Pfad)
  Pfad = Pfad & "\" & Tag
  CheckFolder(Pfad)
 
  DateiSystem.MoveFile Datei.Path, Pfad & "\"
Next
 
Sub CheckFolder(Ordner)
  If Not DateiSystem.FolderExists(Ordner) Then
    DateiSystem.CreateFolder(Ordner)
  End If
End Sub