Creation dossier par rapport a une valeur : cellule excel

Bonjour,

Un code qui devrait marcher :

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

Cordialement.

Edit : J'ai été obligé de répéter l'information contenue en A1 en B1 pour pouvoir supprimer le dossier ensuite, question de "stockage de variable". Vous pouvez toujours changer B1 par une autre cellule inutilisée sur une autre feuille par exemple.

ta demande change!

pour le chemin c'est simple:

tu remplaces:

chemin = objShell.SpecialFolders("Desktop")

par

chemin = "ton chemin"

et pour associer à 100 cellules, tu te sers d'une boucle, en utilisant le code de création de dossier que je t'ai donné:

https://www.developpez.net/forums/d605223/logiciels/microsoft-office/excel/contribuez/boucles-parcourir-colonne-ligne-plage-donnees-2-methodes/

Bonjour,

Faire Alt F11 pour accéder à l'Editeur, ensuite sélectionner la feuille concernée en haut à gauche et mettre ce code:

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

Merci cs_Le Pivert ça marche bien je viens de tester par contre si j'ai un chemin spécifique autre que le bureau je fais comment?

Autre question si c'est pas une cellule mais 100 cellules de ma colonne A que je veux associer un dossier avec des noms différents je fais comment?

Bonjour,

Salut à tous les protagonistes.

J'arrive un peu tard avec ma solution...
A insérer dans le module de la feuille et adapter la Const MON_CHEMIN

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

Salut ,

Merci pour votre aide cela marche super bien !!!

Par contre j'avais une question quand je veux supprimer la ligne complete , par exemple ligne 1 , j'ai un message d'erreur , faut t'il remodifier le macro pour que quand on supprime une ligne le dossier disparaisse?

Merci d'avance

au pire pijaku ou cs_Le pivert pourrais je avoir vos mails que je vous envoie mon tableau que j'ai fais pour mieux expliquer mon probleme?

Re,
En fait voilà la source de mon problème :
J'ai créé un tableau avec des problèmes machines et différentes machines affichées en feuille 2.




Quand on clique sur le bouton INSERTION LIGNE une nouvelle ligne apparait on rentre la date (CTRL+;) ensuite dans la colonne MACHINE j'ai créé une liste déroulante (feuille 2)

Macro INSERER LIGNE

Sub Macro2()
'
' Macro2 Macro
'

'
ActiveWorkbook.Worksheets("Feuille informatisée").ListObjects("Tableau2").Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Feuille informatisée").ListObjects("Tableau2").Sort. _
SortFields.Add Key:=Range("Tableau2[#All,[DATE]]"), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuille informatisée").ListObjects("Tableau2"). _
Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("J5000").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End Sub

Dans les 4 petites colonnes suivante j'ai créé une macro pour cliquer sur quelle partie de la machine je travaille une croix apparait.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("E6:H500"), Target) Is Nothing Then
If UCase(Target) = "X" Then Target = "" Else Target = "X"
Cancel = True
End If
End Sub

Ensuite les deux autres colonnes sont rentrées manuellement pour la nature de la panne et les actions mise en oeuvre. Et ensuite vient ma bête noire lol le fameux lien hypertexte où je dois des créer un dossier automatiquement à chaque insertion de ligne (pour y mettre des photos ou des devis de pièces) qui sera sur le bureau.
Ce que je veux c'est que quand je veux supprimer une ligne le dossier se supprime aussi.
Autre problème si par exemple je rentre une ligne entière le 28/10/2015 et que j'ai oublié de rentrer une ligne la veille donc le 27/10/2015 et que cette date je la rentre après le 28/10/2015, mon tri de date va se faire mais le dossier lien hypertexte sera décalé.
En gros j'aimerais pouvoir quand on fait un tri de date que les le dossier corresponde à la date souhaité et pas à la ligne.

Et j'aimerais quand je clique sur mon numéro de machine de ma liste déroulante qu'il y est automatiquement le type associé (feuille 2). J'ai vu qu'il y avait une formule de index et equiv qui pouvait marcher ?

Un grand merci d'avance

Une idée!

Pourquoi ne pas associer la création du lien Hypertexte, à la création du dossier correspondant par macro, en indiquant la cellule.

tu aurais un exemple à me donner?

Suivant le code de pijaku. Tu saisies dans la cellule, le lien est automatique, tu cliques sur le numéro de ligne(important)
Pour supprimer une ligne, il faut d'abord supprimé le lien pour supprimer le dossier (important) et ensuite supprimer la ligne:

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

des que je rentre une valeur ça me met ça c'est normal?

Tu saisies dans la cellule, le lien est automatique, tu cliques sur le numéro de ligne(important)

eurêka, j'ai trouvé:

Tu saisies et tu tapes au clavier sur la touche Fin

je m'excuse auprès de pijaku pour les Error Resume Next, je n'ai pas trouvé autre chose!

Bonne soirée

--
@+ Le Pivert

re,
cela marche avec la touche fin mais peut on le faire automatiquement , c'est à dire sans à avoir à appuyer sur fin

Merci d'avance

J'ai essayé cette méthode:

https://docs.microsoft.com/fr-fr/office/vba/api/excel.application.sendkeys?redirectedfrom=MSDN

j'ai bloqué Excel et étais obligé de redémarrer le PC!

On va voir si pijaku trouve une solution

ok merci de votre rapidité moi je vais essayer de potasser le sujet dans mon coin aussi

En attendant je suis buté sur l'ordre des macros , enfin je pense que ça vient de la car des que je rentre une de vos macro précédente voila ce que j'ai en défaut



et voila la ligne qui est surlignée



Est ce normal? que faut-il que je fasses? merci d'avance

Voici déjà une petite amélioration du code de Le Pivert :

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

Pour la suppression, par contre, je ferais une colonne avec des X. On pourrait faire les suppressions de ligne lors d'un clic dans les cellules de cette colonne...

J'apporte ma petite pierre à l'édifice,

avec le clic droit:

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