Das Sortieren von Dateien automatisieren

[Cherubim]

Guten Morgen,

ich habe hier auf der Arbeit gerade festgestellt, das der Eingangsordner (Vertrieb) von Kundenteilen und Dateien von Externen eine mittlere Katastrophe ist.
Ich habe jetzt aber keine Lust, manuell Jahre an "einfach reingeworfen" zu sortieren.

Gibt es eine Möglichkeit, automatisiert und eventuell über Unterordner (Neuer Ordner oder Herr XYZ oder einfach ein Datum) Dateien an ihrem Dateinamen in Ordner zu sortieren?
Das einzige was geklappt hat ist, dass alle Dateien mit dem Namen der Firma bzw der Person beginnen, dann ein -
Zb: Firma ABC - Datensatz Maschine 1 22.10.18.zip

Ich suche also etwas, dass jetzt darüber läuft und erkennt "Firma ABC", dann, wenn noch nicht vorhanden, einen Ordner "Firma ABC" erstellt und die Datei und alle anderen der Firma ABC da rein verschiebt.

[cessy000]

lässt sich relative einfach über VBA realisieren...Irgendeine Erfahrung damit ?

Deinen text kannst du genauso übrigens bei CHATGPT eingeben und du bekommst ein funktionierendes Programm das du noch anpassen kannst.
Wenn du nach VBA programm fragst.
Hab es gerade eben ausprobiert:

Beispiel:

Sub SortiereDateien()
Dim Eingangsordner As String
Dim Zielordner As String
Dim Dateiname As String
Dim Firmenname As String
Dim Firmenordner As String

' Definiere den Pfad zum Eingangsordner
Eingangsordner = "Pfad\zum\Eingangsordner"

' Überprüfe, ob der Eingangsordner existiert
If Dir(Eingangsordner, vbDirectory) = "" Then
MsgBox "Der angegebene Eingangsordner existiert nicht.", vbExclamation
Exit Sub
End If

' Durchlaufe alle Dateien im Eingangsordner
Dateiname = Dir(Eingangsordner & "*.*")
Do While Dateiname <> ""
' Überprüfe, ob es sich um eine Datei handelt (kein Ordner)
If Not (GetAttr(Eingangsordner & Dateiname) And vbDirectory) = vbDirectory Then
' Extrahiere den Firmennamen aus dem Dateinamen
Firmenname = ExtrahiereFirmenname(Dateiname)
' Wenn ein Firmenname gefunden wurde
If Firmenname <> "" Then
' Erstelle den Zielordner für die Firma, falls er nicht existiert
Zielordner = Eingangsordner & Firmenname & ""
If Dir(Zielordner, vbDirectory) = "" Then
MkDir Zielordner
End If
' Verschiebe die Datei in den Zielordner
FileCopy Eingangsordner & Dateiname, Zielordner & Dateiname
Kill Eingangsordner & Dateiname
End If
End If
' Gehe zur nächsten Datei
Dateiname = Dir
Loop

MsgBox "Die Dateien wurden erfolgreich sortiert.", vbInformation
End Sub

Function ExtrahiereFirmenname(Dateiname As String) As String
Dim Teile() As String
' Teile den Dateinamen anhand des Trennzeichens "-" auf
Teile = Split(Dateiname, "-")
' Extrahiere den Firmennamen aus dem ersten Teil des Dateinamens
If UBound(Teile) > 0 Then
ExtrahiereFirmenname = Trim(Teile(0))
Else
ExtrahiereFirmenname = ""
End If
End Function

[Cherubim]

Hi, danke schon mal für die ChatGPT idee.

Nein, bisher habe ich noch nichts programiert, aber das kann man ja glatt mal versuchen.

Edit: Das hat geklappt. Nach ein paar anläufen hat mir ChatGPT diesen Script geschrieben:


Sub DateienVerschieben()
On Error GoTo ErrorHandler ' Fehlerbehandlung aktivieren

Dim Quellordner As String
Dim Zielordner As String
Dim fso As Object
Dim Datei As Object
Dim ZielordnerPfad As String
Dim TrennIndex As Long
Dim DateiName As String

' Quellordner auswählen
Quellordner = GetSelectedFolder("Bitte wählen Sie den Quellordner aus.")

' Überprüfe, ob ein Ordner ausgewählt wurde
If Quellordner = "" Then Exit Sub ' Wenn kein Ordner ausgewählt wurde, beende die Subroutine

' Initialisiere das FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

' Durchlaufe alle Dateien im Quellordner
For Each Datei In fso.GetFolder(Quellordner).Files
' Überprüfe, ob die Datei gültig ist
If IstDateiGültig(Datei.Name) Then
' Extrahiere den Namensteil (alles vor dem ersten Leerzeichen und Bindestrich)
Zielordner = Left(Datei.Name, InStr(Datei.Name, " - ") - 1)
ZielordnerPfad = Quellordner & "\" & Zielordner & "\"

' Erstelle den Zielordner, falls er noch nicht existiert
If Not fso.FolderExists(ZielordnerPfad) Then MkDir ZielordnerPfad

' Speichere den Dateinamen für spätere Überprüfung
DateiName = Datei.Name

' Versuche, die Datei zu verschieben
Shell "cmd /c move """ & Quellordner & "\" & Datei.Name & """ """ & ZielordnerPfad & Datei.Name & """", vbHide

' Überprüfe, ob die Datei nach dem Verschieben immer noch vorhanden ist
If fso.FileExists(Quellordner & "\" & DateiName) Then
End If
End If
Next Datei

MsgBox "Dateien wurden verschoben.", vbInformation, "Fertig"
Exit Sub ' Erfolgreicher Exit

ErrorHandler:
MsgBox "Ein Fehler ist aufgetreten: " & Err.Description, vbCritical, "Fehlermeldung" ' Fehlermeldung anzeigen
Exit Sub ' Beende die Subroutine
End Sub

Function IstDateiGültig(DateiName As String) As Boolean
' Überprüft, ob eine Datei gültig ist

Dim TrennIndex As Long

' Suche nach dem ersten Leerzeichen und Bindestrich
TrennIndex = InStr(DateiName, " - ")
If TrennIndex > 0 Then
IstDateiGültig = True
Else
IstDateiGültig = False
End If
End Function

Function GetSelectedFolder(Title As String) As String
' Zeigt einen Ordnerauswahldialog an und gibt den ausgewählten Ordner zurück

Dim fd As FileDialog
Dim SelectedFolder As Variant

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = Title
.AllowMultiSelect = False
If .Show = -1 Then
SelectedFolder = .SelectedItems(1)
Else
SelectedFolder = ""
End If
End With

GetSelectedFolder = SelectedFolder
End Function

[=Floi=]

läuft das dann über dot.net?
einfach als vba speichern?

[Cherubim]

Ja, hab ich einfach in Excel VBA kopiert und von da ausgeführt.