Adaptation d'un code VBA

N

nauj

XLDnaute Junior
Bonjour Forum,
Voici mon sujet :
J'ai trouvé un code VBA sur le web qui me convient parfaitement excepté le fait que le résultat attendu s'applique sur la cellule active alors que mon souhait est de "fixer" le résultat sur les cellules A2 et B2 de la feuille 1.
Après plusieurs tentatives personnelles infructueuses, je me retourne vers vos compétences toujours efficaces !
Je vous joins le code en question et remercie d'avance pour ceux qui souhaiteraient s’intéresser à ce sujet.
Je peux également fournir un fichier exemple si nécessaire
Cdt
Nauj
Code: 
Private Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

    ExtLocale = ExtFichier
    LeFichier = Dir(RepertParent & ExtFichier)
    If Len(LeFichier) = 0 Then
        ActiveCell.Value = RepertParent
        ActiveCell.Offset(1, 0).Select
    End If
    Do While Len(LeFichier) <> 0
        ActiveCell.Value = RepertParent
        ActiveCell.Offset(0, 1).Select
        ActiveCell.Value = LeFichier
        ActiveCell.Offset(1, -1).Select
        LeFichier = Dir
    Loop
    'Compter le nombre de sous-répertoires
    NbreRepert = 0
    LeDossier = Dir(RepertParent, vbDirectory)
    Do While LeDossier <> ""
        If LeDossier <> "." And LeDossier <> ".." Then
            If (GetAttr(RepertParent & LeDossier) _
                    And vbDirectory) = vbDirectory Then
                NbreRepert = NbreRepert + 1
            End If
        End If
        LeDossier = Dir
    Loop
    ReDim LeDossierLocal(NbreRepert + 1)
    Compteur = 1
    LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
    Do While LeDossierLocal(Compteur) <> ""
        If LeDossierLocal(Compteur) <> "." _
                    And LeDossierLocal(Compteur) <> ".." Then
            If (GetAttr(RepertParent & LeDossierLocal(Compteur)) _
                        And vbDirectory) = vbDirectory Then
                Compteur = Compteur + 1
            End If
        End If
        LeDossierLocal(Compteur) = Dir
    Loop
    For Compteur = 1 To UBound(LeDossierLocal()) - 1
        ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
        Call Remplir(ParentLocal, ExtLocale)
    Next
End Sub
 
Trier par date Trier par votes
Papou-net

Papou-net

XLDnaute Barbatruc
Re : Adaptation d'un code VBA

Bonjour nauj,

Pas facile de tester sans fichier, mais peut-être qu'en modifiant ton code comme suit tu obtiendras le résultat visé :

Code: 
Private Sub Remplir(RepertParent, ExtFichier)
' Remplit la feuille courante avec le contenu du répertoire RepertParent
' Les noms de répertoires sont placés dans la colonne active à partir de
' la cellule active
' Les noms de fichiers correspondants à ExtFichier sont affichés dans la
' colonne de droite
' 14/02/2000 18:30, Gérard B, mpfe

Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String

    ExtLocale = ExtFichier
    LeFichier = Dir(RepertParent & ExtFichier)
    If Len(LeFichier) = 0 Then
        ActiveCell.Value = RepertParent
        ActiveCell.Offset(1, 0).Select
    End If
    Do While Len(LeFichier) <> 0
        Sheets("Feuil1").Range("A2").Value = RepertParent
        Sheets("Feuil1").Range("B2").Value = LeFichier
        LeFichier = Dir
    Loop
    'Compter le nombre de sous-répertoires
    NbreRepert = 0
    LeDossier = Dir(RepertParent, vbDirectory)
    Do While LeDossier <> ""
        If LeDossier <> "." And LeDossier <> ".." Then
            If (GetAttr(RepertParent & LeDossier) _
                    And vbDirectory) = vbDirectory Then
                NbreRepert = NbreRepert + 1
            End If
        End If
        LeDossier = Dir
    Loop
    ReDim LeDossierLocal(NbreRepert + 1)
    Compteur = 1
    LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
    Do While LeDossierLocal(Compteur) <> ""
        If LeDossierLocal(Compteur) <> "." _
                    And LeDossierLocal(Compteur) <> ".." Then
            If (GetAttr(RepertParent & LeDossierLocal(Compteur)) _
                        And vbDirectory) = vbDirectory Then
                Compteur = Compteur + 1
            End If
        End If
        LeDossierLocal(Compteur) = Dir
    Loop
    For Compteur = 1 To UBound(LeDossierLocal()) - 1
        ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
        Call Remplir(ParentLocal, ExtLocale)
    Next
End Sub

Espérant avoir répondu.

Cordialement.
 
Vote positif 0 Vote négatif
N

nauj

XLDnaute Junior
Re : Adaptation d'un code VBA

Bonjour Papou-net, Forum,
Je te remercie pour ta proposition aussi rapide. Je l'ai testé et malheureusement, cela ne fonctionne pas correctement.
Je joins un fichier exemple avec le code complet.
Merci encore pour l’intérêt que vous pouvez porter à mon problème
Cdt
Nauj
 

Pièces jointes

  • Classeur_Nauj.xlsm
    24.7 KB · Affichages: 47
Vote positif 0 Vote négatif
N

nauj

XLDnaute Junior
Re : Adaptation d'un code VBA

Papou-net, Forum,
Bien sûr, je vais m'efforcer d'être explicite : Ce fichier permet de récupérer le chemin et les noms des fichiers dans un répertoire choisi. Le résultat attendu s'affiche sur un nouvel onglet (crée par la macro) à la cellule A1.
Ce résultat me convient parfaitement. En revanche, je souhaiterais qu'il puisse s'afficher non pas sur un nouvel onglet crée mais bien sur un onglet déterminé - par exemple sur l'onglet feuil1 - et sur la cellule A1.
J'ai tenté pas mal de manipulations sur ce code sans succès...
J'espère avoir été assez précis dans mon explication, n'hésite pas à me relancer si nécessaire.
Merci encore pour ton temps passé sur ce sujet.
Cdt
Nauj
 
Vote positif 0 Vote négatif
Papou-net

Papou-net

XLDnaute Barbatruc
Re : Adaptation d'un code VBA

Re nauj,

Si j'ai bien compris, voici la modification que j'ai faite sur ton code :

Code: 
Sub AfficheFichiersEtChemins()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean

  LeTitre = "Répertoires et sous-répertoires"
  Arret = False
  Application.ScreenUpdating = False
  Range("A1").Select
  Do
    LeChemin = ChoisirDossier
    If Len(LeChemin) = 0 Then
      Arret = True
    Else
      If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
        LeChemin = LeChemin + "\"
      End If
      If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
        Lextension = InputBox("Taper le type de fichier à afficher", _
                              LeTitre, "*.xls")
        Call Remplir(LeChemin, Lextension)
        Arret = True
      Else
        LeMessage = "Répertoire introuvable...Recommencer ?"
      End If
    End If
  Loop Until Arret
  With ActiveSheet
    Columns("A:B").AutoFit
    .UsedRange.Sort Range("A1")
  End With
End Sub

J'ai remplacé "Sheets.Add" par "Range("A1").Select"

Vérifies sur la copie de ton fichier ci-jointe si ça ta convient.

Cordialement.
 

Pièces jointes

  • Copie de Classeur_Nauj-1.xls
    51 KB · Affichages: 45
Vote positif 0 Vote négatif
N

nauj

XLDnaute Junior
Re : Adaptation d'un code VBA

Papou-net, Forum,
Je viens de le tester mais ça ne fonctionne pas. Son exécution s'arrête avec un Code 1004 : "la méthode Sort de la classe Range a échoué" en pointant sur la ligne de code : .UsedRange.Sort Range("A1")
Désolé, mais n'ai pas les compétences vba pour solutionner seul ce problème.
Si tu as une idée de la solution, suis preneur.
Merci encore
Cdt
Nauj
 
Vote positif 0 Vote négatif
C

Compte Supprimé 979

Guest
Re : Adaptation d'un code VBA

Bonsoir Nauj,

Peux-tu nous joindre ton fichier !?

Chez moi le code de papou-net fonctionne parfaitement
Il y a juste un truc à changer
Code: 
Columns("A:B").AutoFit
par
Code: 
.Columns("A:B").AutoFit
avec le point devant "Columns"

A+
 
Vote positif 0 Vote négatif
N

nauj

XLDnaute Junior
Re : Adaptation d'un code VBA

Bonsoir BrunoM45, Papou-net, Forum,
Je viens de tester le code modifié de Papou-net en rajoutant le "." devant Columns et ça fonctionne parfaitement !
Merci encore pour votre contribution, votre patience (car il en faut :) et surtout votre efficacité.
Bonne continuation à vous et à bientôt
Je ferme ce fil de discussion
Cdt
Nauj
 
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
Microsoft 365 Créer dossiers, sous-dossiers et enregistrer sous OneDrive en ligne
Réponses
0
Affichages
161
Casim
C
D
  • Question
Microsoft 365 Couper Coller Fichiers en VBA
Réponses
3
Affichages
274
patricktoulon
patricktoulon
P
  • Question
XL 2019 VBA moteur de recherche
2
Réponses
21
Affichages
1 K
philgood54000
P
Y
  • Question
probléme au niveau mon code vba
Réponses
3
Affichages
90
Dranreb
Dranreb
F
  • Question
XL 2016 copier des fichiers dans des sous dossiers a partir de case a cocher sous excel
2
Réponses
17
Affichages
535
Felipe54
F
chaelie2015
  • Résolu(e)
XL 2013 Afficher date arrivé sous condiotion
2
Réponses
15
Affichages
543
chaelie2015
chaelie2015
PoloTaz67
  • Question
XL 2019 Aide pour un code
Réponses
1
Affichages
287
Compte Supprimé 979
C
I
  • Question
Microsoft 365 Renommer des fichiers avec des caractères non reconnus
Réponses
10
Affichages
425
ivan27
I
T
  • Question
XL 2016 Code VBA sous un macos
Réponses
4
Affichages
242
telemarrk
T
chaelie2015
  • Question
XL 2013 Réduire un code
Réponses
0
Affichages
208
chaelie2015
chaelie2015

Membres actuellement en ligne

2 membres et 57 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 104
Messages
2 085 349
Membres
102 869
dernier inscrit
radyreth