creation dossier par rapport a une valeur : cellule excel Résolu

Question

Bonjour,

Ma question est simple, il y a t-il une macro qui peut créer un dossier en fonction d'une valeur d'une cellule ? 
Par exemple si je rentre la valeur 55 dans la cellule A1 un dossier 55 ce créer dans mon bureau C:\Users\math74200\Desktop ?
Et à l'inverse si je retire la valeur 55 de la case A1 mon dossier s'efface ? 


Merci d'avance

Kuartz · Answer

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.

cs_Le Pivert · Answer

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

math74200 · Answer

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?

cs_Le Pivert · Answer

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/

pijaku · Answer

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

math74200 · Answer

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

math74200 · Answer

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?

math74200 · Answer

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

cs_Le Pivert · Answer

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.

math74200 · Answer

tu aurais un exemple à me donner?

cs_Le Pivert · Answer

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

math74200 · Answer

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

cs_Le Pivert · Answer

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

cs_Le Pivert · Answer

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

math74200 · Answer

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

cs_Le Pivert · Answer

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

math74200 · Answer

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

math74200 · Answer

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

pijaku · Answer

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...

cs_Le Pivert · Answer

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

math74200 · Answer

ça marche bien avec le click super
par contre je voulais savoir avec mon bouton rajout ligne on pouvais automatiquement avoir un numéro de dossier dans la colonne lien.
par exemple je clique sur mon bouton RAJOUT LIGNE et une ligne se rajoute automatiquement en ligne 6 avec un numero 1 dans la colonne L6  lien qui sera mon dossier 1 lien hypertexte . Si je clique sur RAHOUT LIGNE encore une ligne se met en ligne 7 et un numero 2 dans la colone L7 lien qui sera mon dossier 2 lien hypertexte etcc

cs_Le Pivert · Answer

Ce que tu veux faire, il n'y a que toi qui le sait. Le plus simple avec ce que l'on t'a donné , c'est de mettre une inputBox dans ton bouton avec les demandes de ligne de nom etc. Comme l'exemple de la suppression de ligne. Quand tu ne sais pas sers toi de l'enregistreur de macro.

Si tu rencontre des problème, tu reviens sur ce forum

Bon courage

math74200 · Answer

re ,
j'ai trouvé une commande pour incrémenter dans mon bouton la valeur de ma colonne voici mon macro

 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
   ActiveSheet.Range("L6").Value = ActiveSheet.Range("L6").Value + 1
End Sub


la ligne que j'ai rajouté c'est la dernière. sauf qu'au lieu que cela m'incrémente cellule par cellule ça m'incrémente que dans la cellule L6 c'est normal? 

Merci d'avance

Creation dossier par rapport a une valeur : cellule excel - Page 2

Newsletters