XL 2016 boucle de recherche

[MOEZ-TUN]

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

 

[Dudu2]

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 ?

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

 

[MOEZ-TUN]

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

.
.
.
..
.

 

[Dudu2]

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

 

[MOEZ-TUN]

merci pour votre support

 

[MOEZ-TUN]

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

 

[Dudu2]

Bonjour,
Poste un autre sujet et utilise le format indiqué sous le symbole </> dans la barre de menu du message pour copier ton code sinon c'est illisible, surtout en gras coloré.

 

[Dranreb]

Bonsoir.
Une proposition :

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