Hello colleagues,
I don't know where to post this, so I'm putting it there. I developed with the help of chatgpt 
a macro that puts the Steps in a folder with its name.'. if you have a folder with about fifty Steps; you run the macro from an Excel file in the folder where all the Steps are located and it creates a folder for each Step with the name of it
it can always be useful
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
