Hallo Kolleginnen und Kollegen,
Ich weiß nicht, wo ich das posten soll, also stelle ich es dort hin. Ich habe mit Hilfe von chatgpt 
ein Makro entwickelt, das die Schritte in einem Ordner mit seinem Namen ablegt. Wenn Sie einen Ordner mit etwa fünfzig Schritten haben, führen Sie das Makro aus einer Excel-Datei in dem Ordner aus, in dem sich alle Schritte befinden, und es erstellt einen Ordner für jeden Schritt mit dem Namen des Schritts
Es kann immer nützlich sein
Option Explicit
Sub RepertorierFichiers()
Dim CheminDossier As String
Dim Fichier As String
Dim NouveauDossier As String
Dim FSO As Object ' FileSystemObject
' Obtenir le chemin du dossier actuel
CheminDossier = ThisWorkbook.Path & "\"
' Vérifier si le dossier existe
If Dir(CheminDossier, vbDirectory) = "" Then
MsgBox "Le dossier spécifié n'existe pas."
Exit Sub
End If
' Désactiver les mises à jour pour accélérer le processus
Application.ScreenUpdating = False
' Créer une instance du FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
' Boucle à travers tous les fichiers du dossier actuel avec l'extension STP/STEP
Fichier = Dir(CheminDossier & "*.stp")
Do While Fichier <> ""
' Ignorer les dossiers
If Not (GetAttr(CheminDossier & Fichier) And vbDirectory) = vbDirectory Then
' Extraire le nom du fichier sans extension
NouveauDossier = Left(Fichier, InStrRev(Fichier, ".") - 1)
' Limiter le nom du dossier à 100 caractères maximum
If Len(NouveauDossier) > 100 Then
NouveauDossier = Left(NouveauDossier, 100)
End If
' Créer un nouveau dossier s'il n'existe pas déjà
If Not FolderExists(CheminDossier & NouveauDossier) Then
On Error Resume Next
FSO.CreateFolder CheminDossier & NouveauDossier
On Error GoTo 0
' Vérifier si le dossier a été créé avec succès
If Not FolderExists(CheminDossier & NouveauDossier) Then
MsgBox "Impossible de créer le dossier : " & CheminDossier & NouveauDossier
Exit Sub
End If
End If
' Copier le fichier vers le nouveau dossier
On Error Resume Next
FSO.CopyFile CheminDossier & Fichier, CheminDossier & NouveauDossier & "\" & Fichier
On Error GoTo 0
' Vérifier si la copie a réussi
If Not FileExists(CheminDossier & NouveauDossier & "\" & Fichier) Then
MsgBox "Impossible de copier le fichier : " & CheminDossier & Fichier
Else
' Supprimer le fichier d'origine
On Error Resume Next
FSO.DeleteFile CheminDossier & Fichier
On Error GoTo 0
End If
End If
' Passer au fichier suivant
Fichier = Dir
Loop
' Libérer l'objet FileSystemObject
Set FSO = Nothing
' Activer les mises à jour
Application.ScreenUpdating = True
MsgBox "Le processus est terminé !"
End Sub
Function FolderExists(FolderPath As String) As Boolean
On Error Resume Next
FolderExists = (GetAttr(FolderPath) And vbDirectory) = vbDirectory
On Error GoTo 0
End Function
Function FileExists(FilePath As String) As Boolean
On Error Resume Next
FileExists = (GetAttr(FilePath) And vbDirectory) <> vbDirectory
On Error GoTo 0
End Function
