macro: étendre la recherche sur un repertoire

[woow74]

Bonjour Robert, bonjour le forum

J'ai réussi à avoir cette macro qui fait une recherche d'elements dans un fichier :

Sub test()

Workbooks.OpenText Filename:= _
"D:\Users\ysebbarh.EMEA\Desktop\RAF1.txt"
Workbooks.OpenText Filename:= _
"D:\Users\ysebbarh.EMEA\Desktop\NIR1.txt"
Columns("A:A").Select
Selection.NumberFormat = "0"
Sheets.Add
ActiveSheet.Name = "Resultat"
i = 1
For j = 2 To 16
valeur = Workbooks("NIR1.txt").Sheets("NIR1").Cells(j, 1)
Workbooks("RAF1.txt").Activate
Set celluletrouvee = Range("A:A").Find(valeur)
ligne = celluletrouvee.Row
Do
Workbooks("NIR1.txt").Sheets("Resultat").Cells(i, 1) = Workbooks("RAF1.txt").Sheets("RAF1").Cells(ligne, 1)
i = i + 1
ligne = ligne + 1
Loop Until (Left(Workbooks("RAF1.txt").Sheets("RAF1").Cells(l igne, 1), 14)) = "S30.G01.00.001"
Next
End
End Sub

Donc cette macro recherche dans le fichier RAF1.txt (à partir de données qui sont dans NIR1.txt) et retourne une feuille Excel de resultats, ce que je veux c'est lui spécifier un répertoire RAF ( qui contient plusieurs fichiers RAF*.txt) et faire la même recherche dedans.
J'espère que je suis assez clair sur ce point
Merci tout le monde

 

[woow74]

Re : macro: étendre la recherche sur un repertoire

Re-bonjour tout le monde ,

Voila l'essai que j'ai fais sur la macro pour qu'elle fasse la recherche dans un repertoire mais quand je la lance il ne se passer rien , même pas un message d'erreur

Sub test1()
Dim v_fichier As String
Dim v_i As Byte
v_i = 1
v_fichier = Dir("D:\Users\ysebbarh.EMEA\Desktop\RAF\RAF" & v_i & ".txt")
While v_fichier <> ""
  Workbooks.OpenText Filename:= _
        "D:\Users\ysebbarh.EMEA\Desktop\" & v_fichier

  Workbooks.OpenText Filename:= _
        "D:\Users\ysebbarh.EMEA\Desktop\test_macro\NIR1.txt"
            
        Columns("A1:A1").Select
  Selection.NumberFormat = "0"
  Sheets.Add
     ActiveSheet.Name = "Resultat"
               i = 1
        For j = 2 To 15
        valeur = Workbooks("NIR1.txt").Sheets("NIR1").Cells(j, 1)
        Workbooks(v_fichier).Activate
        Set celluletrouvee = Range("A:A").Find(valeur)
  ligne = celluletrouvee.Row
        Do
      Workbooks("NIR1.txt").Sheets("Resultat").Cells(i, 1) = Workbooks(v_fichier).Sheets(v_fichier).Cells(ligne, 1)
      i = i + 1
      ligne = ligne + 1
      Loop Until (Left(Workbooks(v_fichier).Sheets("RAF" & v_i).Cells(ligne, 1), 14)) = "S30.G01.00.001"
   Next
   v_i = v_i + 1
   v_fichier = Dir("D:\Users\ysebbarh.EMEA\Desktop\RAF" & v_i & ".txt")   
Wend
End
End Sub

Pouvez vous m'aider pour voir se qui ne va pas ou tout simplement une idée pour débloquer tout ça?

Merci.

 

[Hippolite]

Re : macro: étendre la recherche sur un repertoire

Bonjour,
Je n'ai pas le temps d'étudier ton code, mais
(bêtises...)
A+

 

[Hippolite]

Re : macro: étendre la recherche sur un repertoire

Re,
Voilà comment je verrais la chose
Il est recommendé de mettre le répertoire en variable car en cas de besoin il sera aisé de le changer.

Option Explicit
Public RAFWorkbooks As New Collection

Sub TestSurRepertoire()
  Dim Rep As String, Wb As Variant
  Rep = ThisWorkbook.Path & "\" ' ou "D:\Users\ysebbarh.EMEA\Desktop\"
' Répertoire à adapter
   ListeFichiersRAF (Rep) ' Création de la collection des fichiers RAF*xls
                          ' du répertoire
  For Each Wb In RAFWorkbooks  ' Boucle sur les fichiers

  code

  Next Wb
End Sub



 Sub ListeFichiersRAF(Rep As String) 'Crée la collection des fichiers RAF*xls du répertoire
  Dim Nf As String, i As Long
 For i = 1 To RAFWorkbooks.Count  ' Supprime le premier objet à chaque fois avec
    RAFWorkbooks.Remove 1     ' la boucle, jusqu'à ce que la collection soit vide.
  Next i
  Nf = Dir(Rep & "RAF*.xls")    ' appelle le premier fichier RAF*.xls
  Do While Nf <> ""
    RAFWorkbooks.Add Item:=Nf   ' l'ajoute à la collection
    Nf = Dir                    ' suivant
  Loop
End Sub

 

[woow74]

Re : macro: étendre la recherche sur un repertoire

Bonjour Hippolite , bonjour le forum

Merci Hippolite pour ta réponse.
STP regarde ma macro de plus pret ( j'ai effectué des changements pour que sa soit plus simple à lire)

Sub test()


Dim wb_RAF1      As Workbook
Dim wb_NIR1      As Workbook
Dim sb_RAF1      As Worksheet
Dim sb_NIR1      As Worksheet
Dim ws_resultat  As Worksheet
Dim cel_cherchee As Range
Dim cel_trouvee  As Range
Dim cel_resultat As Range

Workbooks.OpenText Filename:="D:\Users\ysebbarh.EMEA\Desktop\test_macro\NIR1.txt"
Set wb_NIR1 = ActiveWorkbook
Set ws_NIR1 = wb_NIR1.Worksheets(1)
ws_NIR1.Columns(1).NumberFormat = "0"

Workbooks.OpenText Filename:="D:\Users\ysebbarh.EMEA\Desktop\test_macro\RAF1.txt"
Set wb_RAF1 = ActiveWorkbook
Set ws_RAF1 = wb_RAF1.Worksheets(1)

Set ws_resultat = wb_NIR1.Worksheets.Add
ws_resultat.Name = "Resultat"
Set cel_resultat = ws_resultat.Range("A1")

For Each cel_cherchee In ws_NIR1.Range("A2:A16")
    Set cel_trouvee = ws_RAF1.Columns(1).Find(cel_cherchee.Value)
    Do
        cel_resultat.Value = cel_trouvee.Value
        Set cel_resultat = cel_resultat.Offset(1)
        Set cel_trouvee = cel_trouvee.Offset(1)
    Loop Until (Left(cel_trouvee.Text, 14)) = "S30.G01.00.001"
Next
 
End Sub

Maintenant ce que je n'arrive pas à faire ( et j'ai bien étudié ton code) c'est changer ma macro et mettre à la place du fichier que j'ouvre ( RAF1.txt) un repertoire "RAF" qui contient plusieur fichiers RAF*.txt ansi que dans le reste du code...
Merci de bienvouloir m'aider sur ce point

 

[Hippolite]

Re : macro: étendre la recherche sur un repertoire

Bonjour,
erreur
A+

 

[woow74]

Re : macro: étendre la recherche sur un repertoire

Bonjour
????

 

[Hippolite]

Re : macro: étendre la recherche sur un repertoire

Re,
Pour de bon cette fois (j'avais mis la réponse d'un autre fil !)

Non testé car je n'ai pas les fichiers associés
Je n'ai pas examiné le décalage des données importées pour ne pas les écraser dans la boucle.

Option Explicit
Public RAFWorkbooks As New Collection

Sub test()

Dim wb_NIR1      As Workbook
Dim sb_NIR1      As Worksheet
Dim ws_resultat  As Worksheet
Dim cel_cherchee As Range
Dim cel_trouvee  As Range
Dim cel_resultat As Range

Dim ws_NIR1      As Worksheet
Dim ws_RAF       As Worksheet
Dim wb_RAF       As Workbook
Dim sb_RAF       As Worksheet

Workbooks.OpenText Filename:="D:\Users\ysebbarh.EMEA\Desktop\test_macro\NIR1.txt"
Set wb_NIR1 = ActiveWorkbook
Set ws_NIR1 = wb_NIR1.Worksheets(1)
ws_NIR1.Columns(1).NumberFormat = "0"

ListeFichiersRAF ("D:\Users\ysebbarh.EMEA\Desktop\test_macro\") ' Création de la collection des fichiers RAF*.txt
For Each wb_RAF In RAFWorkbooks  ' Boucle sur les fichiers RAF
    Workbooks.OpenText Filename:=wb_RAF
    Set wb_RAF = ActiveWorkbook
    Set ws_RAF = wb_RAF.Worksheets(1)

    Set ws_resultat = wb_NIR1.Worksheets.Add
    ws_resultat.Name = "Resultat"
    Set cel_resultat = ws_resultat.Range("A1")

    For Each cel_cherchee In ws_NIR1.Range("A2:A16")
        Set cel_trouvee = ws_RAF.Columns(1).Find(cel_cherchee.Value)
        Do
            cel_resultat.Value = cel_trouvee.Value
            Set cel_resultat = cel_resultat.Offset(1)
            Set cel_trouvee = cel_trouvee.Offset(1)
        Loop Until (Left(cel_trouvee.Text, 14)) = "S30.G01.00.001"
    Next cel_cherchee
Next wb_RAF
End Sub

 Sub ListeFichiersRAF(Rep As String) 'Crée la collection des fichiers RAF*.txt du répertoire
 Dim Nf As String, i As Long
 For i = 1 To RAFWorkbooks.Count  ' Supprime le premier objet à chaque fois avec
   RAFWorkbooks.Remove 1     ' la boucle, jusqu'à ce que la collection soit vide.
 Next i
  Nf = Dir(Rep & "RAF*.txt")    ' appelle le premier fichier RAF*.txt
 Do While Nf <> ""
    RAFWorkbooks.Add Item:=Nf   ' l'ajoute à la collection
   Nf = Dir                    ' suivant
 Loop
End Sub

A+

Edit : corrigé un RAF1 oublié.

PS utilise

[code=vb] ...

[/CODE]au lieu des balises

 pour une présentation en couleurs.

 

[woow74]

Re : macro: étendre la recherche sur un repertoire

Bonjour hippolite , bonjour le forum,
Je te remercie de m'avoir accorder temps et efforts
J'ai testé ce que tu m'as proposé , mais quand je fait le pas à pas , je vois que la macro n'ouvre que NIR2 et n'ouvre aucun fichier du repertoire RAF.
De plus je ne comprend pas cette ligne de code

For i = 1 To RAFWorkbooks.Count  ' Supprime le premier objet à chaque fois avec
  RAFWorkbooks.Remove 1     ' la boucle, jusqu'à ce que la collection soit vide.

Si à chaque fois elle supprime le fichier jamais elle ne va l'ouvrir...
Merci pour votre aide.

 

[woow74]

Re : macro: étendre la recherche sur un repertoire

plus précisement , quand je lance la macro en pas à pas , ilouvre NIR1.txt , il passe par la ligne ListeFichiersRAF pour la création de la collection des fichiers RAF*.txt passe après à Sub ListeFichiersRAF(Rep As String) et revien sur la boucle For Each wb_RAF In RAFWorkbooks mais resort directement de la boucle sans ouvrir aucun fichier RAF*.txt et sans traiter aucun fichier et repart pour juste réouvrir le fichier NIR1.txt
Voila la situation.
Merci à vous tous pour votre aide

 

[Hippolite]

Re : macro: étendre la recherche sur un repertoire

Bonsoir,
J'ai apporté deux corrections,

Dim wb_RAF       As Variant

et

Workbooks.OpenText Filename:=Rep & wb_RAF

J'ai également introduit le répertoire en variable pour des raisons pratiques.
ça tourne chez moi en se perdant dans le Do Loop du premier fichier RAF.
IL faudrait que tu joignes des fichiers d'essai si tu veux que j'aille plus loin.

Ci-joint le code modifié :

Option Explicit
Public RAFWorkbooks As New Collection

Sub test()

Dim wb_NIR1      As Workbook
Dim sb_NIR1      As Worksheet
Dim ws_resultat  As Worksheet
Dim cel_cherchee As Range
Dim cel_trouvee  As Range
Dim cel_resultat As Range

Dim ws_NIR1      As Worksheet
Dim ws_RAF       As Worksheet
Dim wb_RAF       As Variant     'CORRECTION ICI
Dim sb_RAF       As Worksheet
Dim Rep As String

Rep = ThisWorkbook.Path & "\" 'MODIFICATION ICI Répertoire mis en variable pour adapter facilement
Workbooks.OpenText Filename:=Rep & "NIR1.txt"
Set wb_NIR1 = ActiveWorkbook
Set ws_NIR1 = wb_NIR1.Worksheets(1)
ws_NIR1.Columns(1).NumberFormat = "0"

ListeFichiersRAF (Rep) ' Création de la collection des fichiers RAF*.txt
For Each wb_RAF In RAFWorkbooks  ' Boucle sur les fichiers RAF
   Workbooks.OpenText Filename:=Rep & wb_RAF    'CORRECTION ICI
    Set wb_RAF = ActiveWorkbook
    Set ws_RAF = wb_RAF.Worksheets(1)

    Set ws_resultat = wb_NIR1.Worksheets.Add
    ws_resultat.Name = "Resultat"
    Set cel_resultat = ws_resultat.Range("A1")

    For Each cel_cherchee In ws_NIR1.Range("A2:A16")
        Set cel_trouvee = ws_RAF.Columns(1).Find(cel_cherchee.Value)
        Do
            cel_resultat.Value = cel_trouvee.Value
            Set cel_resultat = cel_resultat.Offset(1)
            Set cel_trouvee = cel_trouvee.Offset(1)
        Loop Until (Left(cel_trouvee.Text, 14)) = "S30.G01.00.001"
    Next cel_cherchee
Next wb_RAF
End Sub

 Sub ListeFichiersRAF(Rep As String)    'Crée la collection des fichiers RAF*.txt du répertoire
Dim Nf As String, i As Long
 For i = 1 To RAFWorkbooks.Count        ' Supprime le premier objet à chaque fois avec
  RAFWorkbooks.Remove 1                 ' la boucle, jusqu'à ce que la collection soit vide.
Next i
  Nf = Dir(Rep & "RAF*.txt")            ' appelle le premier fichier RAF*.txt
Do While Nf <> ""
    RAFWorkbooks.Add Item:=Nf           ' l'ajoute à la collection
  Nf = Dir                              ' suivant
Loop
End Sub

De plus je ne comprend pas cette ligne de code
Code :
For i = 1 To RAFWorkbooks.Count ' Supprime le premier objet à chaque fois avec
RAFWorkbooks.Remove 1 ' la boucle, jusqu'à ce que la collection soit vide.

Si à chaque fois elle supprime le fichier jamais elle ne va l'ouvrir...

Pour des raisons de facilité, j'ai déclaré la collection RAFWorkbooks en Public,
Pour la rafraîchir, je commence par supprimer les items par le dessous de la pile des références des fichiers RAF puis j'ajoute tous les item de fichiers RAF que je trouve. Aucun fichier n'est supprimé, c'est un travail sur des items.

J'aurais pu également mettre qq chose comme

For i = RAFWorkbooks.Count  To 1  -1
 RAFWorkbooks.Remove i
Next i

A+