Creation dossier par rapport a une valeur : cellule excel

Sub Test()
Dim Chemin As String, Dossier As String
Chemin = "C:\Users\math74200\Desktop"
Dossier = Range("A1")

If Range("A1") = "" And Range("B1") = "" Then Exit Sub

If Range("A1") <> "" Then
Range("B1") = Range("A1")
End If
 
If Dir(Chemin & Dossier) = "" Then MkDir Chemin & Dossier

If Range("A1") = "" Then
    If Dir(Chemin & Dossier) <> "" Then RmDir Chemin & Range("B1")
End If

End Sub

Option Explicit
Const Cible = &H10 'Bureau
Dim objShell As Object
Dim objFolder As Object, objFolderItem As Object
Dim chemin As String
Dim GestionFichier As Object
Dim nom As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Not Intersect(Target, Range("A1")) Is Nothing Then
nom = Target.Value
Set objShell = CreateObject("WScript.Shell")
chemin = objShell.SpecialFolders("Desktop")
If nom = "55" Then
On Error Resume Next 'si un dossier existe
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(Cible)
Set objFolderItem = objFolder.Self
 MkDir objFolderItem.Path & "\55"
 MsgBox "Dossier créé"
Else
If Dir(chemin & "\55", vbDirectory) = "" Then Exit Sub 'si dossier inexistant
Set GestionFichier = CreateObject("Scripting.FileSystemObject")
GestionFichier.DeleteFolder chemin & "\55"
Set GestionFichier = Nothing
 MsgBox "Dossier supprimé"
End If
 End If
End Sub

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Private Const MON_CHEMIN As String = "C:\Excel\Repertoires\Sauvegardes\"

Private Cible As String

Private Sub Worksheet_Activate()
   If Not Intersect(Target, Range("A1:A100")) Is Nothing Then Cible = Target.Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
      If Target.Value <> "" Then
         SHCreateDirectoryEx 0, MON_CHEMIN & Target.Value, ByVal 0&
      Else
         If Cible <> "" Then
            If Dir(MON_CHEMIN & Cible, vbDirectory) <> "" Then RmDir MON_CHEMIN & Cible
         End If
      End If
   End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Not Intersect(Target, Range("A1:A100")) Is Nothing Then Cible = Target.Value
End Sub

Option Explicit
Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Private Const MON_CHEMIN As String = "C:\Users\.....\Documents\" 'a adapter

Private Cible As String
Private Sub Worksheet_Activate()
   If Not Intersect(Target, Range("A1:A100")) Is Nothing Then Cible = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
     If Not Intersect(Target, Range("A1:A100")) Is Nothing And _
Union(Target, Range("A1:A100")).Cells.Count = Range("A1:A100").Cells.Count Then
      If Target.Value <> "" Then
      On Error Resume Next
         SHCreateDirectoryEx 0, MON_CHEMIN & Target.Value, ByVal 0&
          ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=MON_CHEMIN & Target.Value
      Else
         If Cible <> "" Then
            If Dir(MON_CHEMIN & Cible, vbDirectory) <> "" Then
               Dim FS
               Set FS = CreateObject("Scripting.FileSystemObject")
               FS.Deletefolder MON_CHEMIN & Cible
            End If
         End If
      End If
   End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
    If Not Intersect(Target, Range("A1:A100")) Is Nothing And _
Union(Target, Range("A1:A100")).Cells.Count = Range("A1:A100").Cells.Count Then Cible = Target.Value
End Sub

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Private Const MON_CHEMIN As String = "C:\Users\.....\Documents\" 'a adapter

Private Cible As String, Cel As Range

Private Sub Worksheet_Activate()
   If Not Intersect(Target, Range("A1:A100")) Is Nothing Then Cible = Target.Value: Set Cel = Target
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
     If Not Intersect(Target, Range("A1:A100")) Is Nothing And _
Union(Target, Range("A1:A100")).Cells.Count = Range("A1:A100").Cells.Count Then
      If Target.Value <> "" Then
      On Error Resume Next
          SHCreateDirectoryEx 0, MON_CHEMIN & Target.Value, ByVal 0&
          Application.EnableEvents = False
          ActiveSheet.Hyperlinks.Add Anchor:=Cel, Address:=MON_CHEMIN & Target.Value
          Application.EnableEvents = True
      Else
         If Cible <> "" Then
            If Dir(MON_CHEMIN & Cible, vbDirectory) <> "" Then
               Dim FS
               Set FS = CreateObject("Scripting.FileSystemObject")
               FS.Deletefolder MON_CHEMIN & Cible
            End If
         End If
      End If
   End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
    If Not Intersect(Target, Range("A1:A100")) Is Nothing And _
Union(Target, Range("A1:A100")).Cells.Count = Range("A1:A100").Cells.Count Then Cible = Target.Value: Set Cel = Target
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim resultat As String
resultat = InputBox("Entrez le numéro de ligne à supprimer", "Suppression ligne") 'La variable reçoit la valeur entrée dans l'InputBox
     If resultat <> "" Then 'Si la valeur est différente de "" on affiche le résultat
      Range("A" & resultat).Select
    Selection.ClearContents
      Rows(resultat & ":" & resultat).Select
    Selection.Delete Shift:=xlUp
     End If
End Sub