XL 2016 boucle de recherche

M

MOEZ-TUN

XLDnaute Occasionnel
Bonjour

J’ai une boucle de rechercher sa fonction convenablement, mais je veux le lancer sur un tableau.

C-à-dire :

Actuel :

Répertoire :Fichiers
C:\dossier1\Resultat1
Resultat2
Resultat3
Resultat4
Resultat5
Resultat6


Objectif :

Répertoire :Fichiers
C:\dossier1\Resultat1(dossier1)
C:\dossier2\Resultat2(dossier2)
C:\dossier3\Resultat3(dossier3)
C:\dossier4\Resultat4(dossier4)
C:\dossier5\Resultat5(dossier5)
C:\dossier6\Resultat6(dossier6)
RM : dans ce cas les résultats est maximum 6 éléments.

La macro actuelle :

Sub Boucle1Fichiers()
Dim Chemin As String, Fichier As String, i As Integer
' Efface liste
Range("C10:C900").ClearContents
'Définit le répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
Chemin = [A10]
'Boucle sur tous les fichiers du répertoire.
Fichier = Dir(Chemin & "*.*")
'Utilisez la syntaxe suivante pour boucler sur tous les types de fichiers:
'Fichier = Dir(Chemin & "*.*")
i = 10
Do While Len(Fichier) > 0
' Range le nom du fichier dans la colonne A
Cells(i, 3) = Fichier
i = i + 1 ' incrément N° de ligne
Fichier = Dir()
Loop
End Sub
 
Trier par date Trier par votes
Dudu2

Dudu2

XLDnaute Barbatruc
Bonjour,
Ça veut dire quoi Resultat1(dossier1) ? C'est 1 fichier ? Le premier trouvé ? Plusieurs fichiers ?
Le tableau c'est quoi ? C'est les répertoires différents ?
VB: 
Sub Boucle1Fichiers()
    Dim Chemin As String, Fichier As String, i As Integer
    
    ' Efface liste
    Range("C10:C900").ClearContents
    
    'Définit le répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
    Chemin = [A10]
    
    'Boucle sur tous les fichiers du répertoire.
    Fichier = Dir(Chemin & "*.*")
    i = 10
    
    Do While Len(Fichier) > 0
        ' Range le nom du fichier dans la colonne A
        Cells(i, 3) = Fichier
        i = i + 1 ' incrément N° de ligne
        Fichier = Dir()
    Loop
End Sub
 
Vote positif 0 Vote négatif
M

MOEZ-TUN

XLDnaute Occasionnel
oui chaque dossier possède maximum 5 fichiers.

voici une simulation du tableau:

Répertoire :Fichiers
C:\dossier1\Fichier1
fichier2
fichier3
C:\dossier2\Fichier21
fichier22
fichier23
ficher 24
fichier2 5
C:\dossier3\Fichier31
fichier32
fichier33
fichier34
.
.
.
..
.
 
Vote positif 0 Vote négatif
Dudu2

Dudu2

XLDnaute Barbatruc
VB: 
Sub Boucle1Fichiers()
    Dim Fichier As String
    Dim CelluleChemin As Range
    Dim i As Integer
    '
    Const NbChemins = 3
    Const CelluleChemin1 = "A10"
    
    ' Efface liste
    ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).ClearContents
    
    For i = 1 To NbChemins
        'Définit la cellule du répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
        Set CelluleChemin = ActiveSheet.Range(CelluleChemin1).Offset(i - 1)
    
        'Boucle sur tous les fichiers du répertoire.
        Fichier = Dir(CelluleChemin.Value & "*.*")
        
        Do While Len(Fichier) > 0
            ' Range le nom du fichier dans la colonne C
            If Len(CelluleChemin.Offset(, 2).Value) > 0 Then CelluleChemin.Offset(, 2).Value = CelluleChemin.Offset(, 2).Value & vbLf
            CelluleChemin.Offset(, 2).Value = CelluleChemin.Offset(, 2).Value & Fichier
            Fichier = Dir()
        Loop
    Next i
    
    ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).EntireRow.AutoFit
End Sub
 
Vote positif 0 Vote négatif
M

MOEZ-TUN

XLDnaute Occasionnel
bonjour
Comment faire pour simplifier ces trois macros

Sub Boucle1Fichiers()
Dim Fichier As String
Dim CelluleChemin As Range
Dim i As Integer
'
Const NbChemins = 3
Const CelluleChemin1 = "A10"

' Efface liste
ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).ClearContents

For i = 1 To NbChemins
'Définit la cellule du répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
Set CelluleChemin = ActiveSheet.Range(CelluleChemin1).Offset(i - 1)

'Boucle sur tous les fichiers du répertoire.
Fichier = Dir(CelluleChemin.Value & "*.*")

Do While Len(Fichier) > 0
' Range le nom du fichier dans la colonne C
If Len(CelluleChemin.Offset(, 1).Value) > 0 Then CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & vbLf
CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & Fichier
Fichier = Dir()
Loop
Next i

ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).EntireRow.AutoFit
End Sub
Sub Boucle1Fichiers1()
Dim Fichier As String
Dim CelluleChemin As Range
Dim i As Integer
'
Const NbChemins = 3
Const CelluleChemin1 = "C10"

' Efface liste
ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).ClearContents

For i = 1 To NbChemins
'Définit la cellule du répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
Set CelluleChemin = ActiveSheet.Range(CelluleChemin1).Offset(i - 1)

'Boucle sur tous les fichiers du répertoire.
Fichier = Dir(CelluleChemin.Value & "*.*")

Do While Len(Fichier) > 0
' Range le nom du fichier dans la colonne C
If Len(CelluleChemin.Offset(, 1).Value) > 0 Then CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & vbLf
CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & Fichier
Fichier = Dir()
Loop
Next i

ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).EntireRow.AutoFit
End Sub
Sub Boucle1Fichiers3()
Dim Fichier As String
Dim CelluleChemin As Range
Dim i As Integer
'
Const NbChemins = 3
Const CelluleChemin1 = "E10"

' Efface liste
ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).ClearContents

For i = 1 To NbChemins
'Définit la cellule du répertoire contenant les fichiers, à modifier. ici fichiers sur écran.
Set CelluleChemin = ActiveSheet.Range(CelluleChemin1).Offset(i - 1)

'Boucle sur tous les fichiers du répertoire.
Fichier = Dir(CelluleChemin.Value & "*.*")

Do While Len(Fichier) > 0
' Range le nom du fichier dans la colonne C
If Len(CelluleChemin.Offset(, 1).Value) > 0 Then CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & vbLf
CelluleChemin.Offset(, 1).Value = CelluleChemin.Offset(, 1).Value & Fichier
Fichier = Dir()
Loop
Next i

ActiveSheet.Range(CelluleChemin1).Offset(, 2).Resize(NbChemins).EntireRow.AutoFit
End Sub
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonsoir.
Une proposition :
VB: 
Option Explicit
Sub Test()
   BoucleFichiers ActiveSheet.[A10:A12]
   BoucleFichiers ActiveSheet.[C10:C12]
   BoucleFichiers ActiveSheet.[E10:E12]
   End Sub
Sub BoucleFichiers(ByVal RDoss As Range)
   Dim TDoss(), TRésu(), L As Long, TJn() As String, NomFic As String, N As Long
   If RDoss.Rows.Count = 1 Then
      ReDim TDoss(1 To 1, 1 To 1): TDoss(1, 1) = RDoss.Value
   Else
      TDoss = RDoss.Value: End If
   ReDim TRésu(1 To UBound(TDoss, 1), 1 To 1)
   For L = 1 To UBound(TDoss, 1)
      ReDim TJn(0 To 49): N = -1
      NomFic = Dir(TDoss(L, 1) & "*.*")
      Do While NomFic <> ""
         N = N + 1: TJn(N) = NomFic
         NomFic = Dir
         Loop
      If N >= 0 Then
         ReDim Preserve TJn(0 To N)
         TRésu(L, 1) = Join(TJn, vbLf)
         End If
      Next L
   RDoss.Offset(, 1).Value = TRésu
   End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

D
  • Question
Microsoft 365 Couper Coller Fichiers en VBA
Réponses
3
Affichages
302
patricktoulon
patricktoulon
Nico2978
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
183
Nico2978
Nico2978
chris6999
  • Question
Microsoft 365 Conserver la valeur de ma variable pour l'utiliser dans un autre code
Réponses
3
Affichages
112
mapomme
mapomme
P
  • Résolu(e)
XL 2016 4 étapes en 1 seule Excel vba
Réponses
4
Affichages
467
Pygos691
P
A
  • Question
XL 2016 Boucle sur sous répertoire fso.GetFolder SharePoint
Réponses
0
Affichages
274
Aldonanou
A
F
  • Question
XL 2016 copier des fichiers dans des sous dossiers a partir de case a cocher sous excel
2
Réponses
17
Affichages
558
Felipe54
F
luke3300
  • Question
Microsoft 365 Erreur de macro
Réponses
4
Affichages
538
luke3300
luke3300
G
  • Question
XL pour MAC VBA export données Excel vers Signets word
Réponses
3
Affichages
721
Staple1600
Staple1600
N
  • Question
XL 2016 Macro chargement liste arborescence, copier coller fichiers
Réponses
9
Affichages
389
Nermal64
N
patricktoulon
  • Résolu(e)
XL 2013 compilation ZIP gestion d'attente
Réponses
5
Affichages
455
cp4
cp4

Membres actuellement en ligne

22 membres et 121 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 213
Messages
2 086 307
Membres
103 174
dernier inscrit
OBUTT