Witam koleżanki i koledzy,
Nie wiem, gdzie to opublikować, więc umieszczam to tam. Opracowałem z pomocą chatgpt
makro, które umieszcza Kroki w folderze z jego nazwą. Jeśli masz folder z około pięćdziesięcioma Krokami; uruchamiasz makro z pliku Excel w folderze, w którym znajdują się wszystkie Kroki, a on tworzy folder dla każdego Kroku z jego nazwą
To zawsze może się przydać
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