Cherche répertoire Supérieur 15 caractères

M

mattwarend

XLDnaute Junior
Bonjour,

J'ai un répertoire Organisation Qualité dans lequel je cherche à trouver l'ensemble des répertoires dont la taille dépasse les 15 caractères.
Pour ce faire, j'ai trouvé une macro Excel (on m'a aidé).
Le problème c'est qu'elle ne fonctionne pas correctement.
Elle ne me remonte pas certain répertoire qui pourtant ont une taille supérieure à 15 caractères et en plus, elle ne fouille pas dans l'ensemble de l'arborescence (Rép Niv1, 2, 3, ...)
Pouvez-vous SVP m'aider sur le sujet.

Macro en PJ.
 

Pièces jointes

  • Cherch Rep Sup A.xls
    30 KB · Affichages: 70
Trier par date Trier par votes
L

Le Pierre

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Bonjour

Voici le code rectifié (Dir au lieu de Dir$) :
Code: 
Sub cherchons(ByVal rep As String, nbmax As Integer)
Dim toto As Integer
  If toto = 0 Then toto = 1
  Dim nf As String, nbr As Integer
  Dim tremplin As String
  Dim i As Integer
  If Right$(rep, 1) <> "\" Then rep = rep & "\"
  [COLOR="magenta"]nf = Dir(rep, vbDirectory)[/COLOR]
  nbr = 1
  Do While nf <> ""
    If nf <> "." And nf <> ".." Then
      tremplin = rep & nf
      If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then
        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        [COLOR="magenta"]nf = Dir(rep, vbDirectory)[/COLOR]
        For i = 2 To nbr
          [COLOR="magenta"]nf = Dir[/COLOR]
        Next
      End If
    End If
    [COLOR="magenta"]nf = Dir[/COLOR]
    nbr = nbr + 1
  Loop
'
End Sub

à plus
 
Vote positif 0 Vote négatif
M

mattwarend

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Salut, merci pour ta réponse mais ça ne fonctionne tjrs pas.
A la racine de mon répertoire Organisation Qualité, j'ai 4 répertoires :
- EQUIPE DOQ
- ORGANISATION
- PMO
- QUALITE

Sous EQUIPE DOQ, j'ai 7 répertoires :
- 00 - ARCHIVES
- 0 - REGLES DE GESTION DES DOCUMENTS DOQ SUR LE RESEAU
- 1-Répertoires personnels
- 2 - FONCTIONNEMENT DIRECTION
- 3 - REGLES GENERALES
- 4 - SUIVIS
- 5 - COMMUNICATION

Ceux en gras devrait être remonté dans la macro, mais ce n'est pas le cas.
 
Dernière édition:
Vote positif 0 Vote négatif
L

Le Pierre

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Bonjour

Essaye en neutralisant le "if ... end if" :
Code: 
[COLOR="magenta"]'If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then[/COLOR]        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        nf = Dir(rep, vbDirectory)
        For i = 2 To nbr
          nf = Dir
        Next
      [COLOR="Magenta"]'End If[/COLOR]
Normalement tous les répertoires doivent être inscrits : est-ce le cas ?
Si non, c'est le nom de ton répertoire de recherche qui est incorrect !
Regarde dans Macro1() si "repertoire = "Y:\Organisation Qualite" ' ici ton répertoire à fouiller" n'est pas, par exemple, "repertoire = "Y:\Mes Documents\Organisation Qualite" ' ici ton répertoire à fouiller" ou ...
à plus
 
Vote positif 0 Vote négatif
M

mattwarend

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Le Pierre à dit:
Bonjour

Essaye en neutralisant le "if ... end if" :
Code: 
[COLOR="magenta"]'If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then[/COLOR]        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        nf = Dir(rep, vbDirectory)
        For i = 2 To nbr
          nf = Dir
        Next
      [COLOR="Magenta"]'End If[/COLOR]
Normalement tous les répertoires doivent être inscrits : est-ce le cas ?
Si non, c'est le nom de ton répertoire de recherche qui est incorrect !
Regarde dans Macro1() si "repertoire = "Y:\Organisation Qualite" ' ici ton répertoire à fouiller" n'est pas, par exemple, "repertoire = "Y:\Mes Documents\Organisation Qualite" ' ici ton répertoire à fouiller" ou ...
à plus
Cliquez pour agrandir...

Salut,

J'ai une erreur sur la ligne suivante :

Code: 
nf = Dir(rep, vbDirectory)

Erreur d'exécution 52. Nom ou numéro de fichier incorrect.
 
Vote positif 0 Vote négatif
L

Le Pierre

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Bonjour

Oui effectivement j'ai aussi la même erreur.
Essaye ceci que je viens de tester :
Code: 
Sub cherchons(ByVal rep As String, nbmax As Integer)
Dim toto As Integer
  If toto = 0 Then toto = 1
  Dim nf As String, nbr As Integer
  Dim tremplin As String
  Dim i As Integer
  If Right$(rep, 1) <> "\" Then rep = rep & "\"
  nf = Dir(rep, vbDirectory)
  nbr = 1
  Do While nf <> ""
    If nf <> "." And nf <> ".." Then
      tremplin = rep & nf
      'If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then
      [COLOR="Magenta"]If GetAttr(tremplin) And vbDirectory Then[/COLOR]
        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        nf = Dir(rep, vbDirectory)
        For i = 2 To nbr
          nf = Dir
        Next
      End If
    End If
    nf = Dir
    nbr = nbr + 1
  Loop
'
End Sub
Tu devrais avoir tous les sous répertoires.
à plus
 
Vote positif 0 Vote négatif
M

mattwarend

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Merci Le Pierre pour ton aide.

Existe t'il une méthode pour ne remonter que les répertoires de Niveau 1 et Niveau 2.

Ex : ressource Y:\

répertoire de Niveau 1 : Y:\Equipe DOQ RESSOURCE
répertoire de Niveau 2 : Y:\Equipe DOQ\DOCUMENTATION GENERALE

Faire en sorte que seuls les répertoires de Niveau 1 (Equipe DOQ RESSOURCE) et Niveau 2 (DOCUMENTATION GENERALE) soient remontés dans la recherche.

Et pas les répertoires en dessous, Niveau 3, Niveau 4, etc...
 
Vote positif 0 Vote négatif
L

Le Pierre

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Bonjour

Voici ce que je te propose :
ce programme scrute le disque C: et liste les répertoires jusqu'à ceux de niveau 2 (fixé par "If NivRep = 2 Then Exit Sub") sans tenir compte du nombre de caractères.

Code: 
Public NivRep As Integer
Public toto As Integer

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 10/11/2008 par brunautma
'
    Dim repertoire As String, maxcar As Integer

    Cells.Select
    Selection.ClearContents
    Range("A1").Select
   
   [COLOR="Magenta"]repertoire = "c:\" [/COLOR]
   'repertoire = "Y:\Organisation Qualite" ' ici ton répertoire à fouiller
   toto = 0
   maxcar = 15 ' ici le nombre maximum de caractères
   cherchons repertoire, maxcar
   
   End Sub
Sub cherchons(ByVal rep As String, nbmax As Integer)
  If NivRep = 2 Then Exit Sub
  'NivRep = niveau de recherche dans les sous répertoires
  '1 = sous répertoire niveau 1
  '2 = sous répertoire niveau 2
  
  If toto = 0 Then toto = 1
  
  Dim nf As String, nbr As Integer
  Dim tremplin As String
  Dim i As Integer
  If Right$(rep, 1) <> "\" Then rep = rep & "\"
  nf = Dir(rep, vbDirectory)
  nbr = 1
  NivRep = NivRep + 1
  Do While nf <> ""
    If nf <> "." And nf <> ".." Then
      tremplin = rep & nf
      [COLOR="magenta"]'[/COLOR]If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then
      [COLOR="magenta"]If GetAttr(tremplin) And vbDirectory Then[/COLOR]
        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        nf = Dir(rep, vbDirectory)
        For i = 2 To nbr
          nf = Dir
        Next
      End If
    End If
    nf = Dir
    nbr = nbr + 1
  Loop
  NivRep = NivRep - 1
'
End Sub
à plus
 
Vote positif 0 Vote négatif
M

mattwarend

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Le Pierre à dit:
Bonjour

Voici ce que je te propose :
ce programme scrute le disque C: et liste les répertoires jusqu'à ceux de niveau 2 (fixé par "If NivRep = 2 Then Exit Sub") sans tenir compte du nombre de caractères.

Code: 
Public NivRep As Integer
Public toto As Integer

Sub Macro1()
'
' Macro1 Macro
' Macro enregistrée le 10/11/2008 par brunautma
'
    Dim repertoire As String, maxcar As Integer

    Cells.Select
    Selection.ClearContents
    Range("A1").Select
   
   [COLOR="Magenta"]repertoire = "c:\" [/COLOR]
   'repertoire = "Y:\Organisation Qualite" ' ici ton répertoire à fouiller
   toto = 0
   maxcar = 15 ' ici le nombre maximum de caractères
   cherchons repertoire, maxcar
   
   End Sub
Sub cherchons(ByVal rep As String, nbmax As Integer)
  If NivRep = 2 Then Exit Sub
  'NivRep = niveau de recherche dans les sous répertoires
  '1 = sous répertoire niveau 1
  '2 = sous répertoire niveau 2
  
  If toto = 0 Then toto = 1
  
  Dim nf As String, nbr As Integer
  Dim tremplin As String
  Dim i As Integer
  If Right$(rep, 1) <> "\" Then rep = rep & "\"
  nf = Dir(rep, vbDirectory)
  nbr = 1
  NivRep = NivRep + 1
  Do While nf <> ""
    If nf <> "." And nf <> ".." Then
      tremplin = rep & nf
      [COLOR="magenta"]'[/COLOR]If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then
      [COLOR="magenta"]If GetAttr(tremplin) And vbDirectory Then[/COLOR]
        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
        cherchons tremplin, nbmax
        nf = Dir(rep, vbDirectory)
        For i = 2 To nbr
          nf = Dir
        Next
      End If
    End If
    nf = Dir
    nbr = nbr + 1
  Loop
  NivRep = NivRep - 1
'
End Sub
à plus
Cliquez pour agrandir...

Salut !

Super, la macro liste maintenant les répertoires de Niveau 1 et Niveau 2 mais ce que j'aimerais c'est qu'elle ne remonte uniquement les répertoires de Niveau 1 et Niveau 2 dont le nombre de caractères dépassent les 15 caractères.
 
Vote positif 0 Vote négatif
L

Le Pierre

XLDnaute Junior
Re : Cherche répertoire Supérieur 15 caractères

Bonjour

Pour ne lister que les répertoires ayant plus de 15 caractères il faut simplement rétablir la situation initiale dans ton code :
Code: 
  Do While nf <> ""
    If nf <> "." And nf <> ".." Then
      tremplin = rep & nf
      [COLOR="Magenta"]If GetAttr(tremplin) And vbDirectory And Len(nf) > nbmax Then[/COLOR]
     [COLOR="magenta"] '[/COLOR][COLOR="SeaGreen"]If GetAttr(tremplin) And vbDirectory Then[/COLOR]
        Sheets("Feuil1").Cells(toto, 1).Value = tremplin
        toto = toto + 1
à plus
 
Vote positif 0 Vote négatif

Discussions similaires

G
  • Question
Recherche conseils avises pour finaliser la realisation d'un tableau de bord
3 4 5
Réponses
70
Affichages
81 K
Bebere
B
M
[REF] Wiki 5 de MichelXld (Formules, Audits de formules, Répertoires, Fichiers)
Réponses
0
Affichages
46 K
MichelXld
M
M
[REF] Wiki Page 9 de MichelXld
Réponses
0
Affichages
38 K
MichelXld
M
M
[REF] Wiki 1 de MichelXld (Généralités Excel)
Réponses
5
Affichages
59 K
Best1
B
M
[REF] Wiki 2 de MichelXld (Ce qui touche aux UserForm)
Réponses
0
Affichages
116 K
MichelXld
M

Membres actuellement en ligne

3 membres et 41 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 338
Messages
2 087 397
Membres
103 535
dernier inscrit
moimeme1