Hallo collega's,
Ik weet niet waar ik dit moet posten, dus ik zet het daar. Ik heb met behulp van chatgpt 
een macro ontwikkeld die de stappen in een map met zijn naam zet.'. als je een map hebt met ongeveer vijftig stappen; je voert de macro uit vanuit een Excel-bestand in de map waar alle stappen zich bevinden en er wordt een map gemaakt voor elke stap met de naam ervan
Het kan altijd nuttig zijn
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
