Recherche d'un fichier dans un répertoire et un boucle...

Bonjour le forum !!

J'ai deux petites questions:

1) J'ai écrit un macro qui fait des opérations sur un fichier texte, il faut que ce macro fasse ces opérations pour tous les fichiers texte qui se trouvent dans le répertoire, donc je dois faire un boucle mais je ne sais pas comment le faire...

2) Avec un macro je veux voir si le fichier qui s'appelle "AA.xls" par exemple existe dans le répértoire que je précise ou pas ("C:\bd\tables" par exemple) . Si il existe je veux l'ouvrir, sinon je veux le créer...

Voilà voilaà... J'espère qu'il y a des gens qui peuvent m'aider...

Merci beaucoup

Les2A

bonjour Les2A

pour la premiere partiede ta question , tu peux essayer

Sub ListeFichiersTxt()
Dim Fichier As String, Chemin As String
Dim LigneTxt

Chemin = "C:\Mes Documents\xl\" 'adapter le chemin
Fichier = Dir(Chemin & "\*.txt", 0)

'boucle sur tous les fichiers txt du repertoire
Do While Len(Fichier) > 0

'exemple d'action sur les fichiers textes :
'à adapter en fonction du projet
Open Chemin & Fichier For Input As #1
Do While Not EOF(1)
Line Input #1, LigneTxt
MsgBox LigneTxt
Loop
Close #1

Fichier = Dir()
Loop

End Sub


bon apres midi
MichelXld

Salut

je tente de modifier le code de Michel Xld pour des fichiers Xls .

Ca gaze plutot bien sauf que la recherche ne se fait qu'au premier niveau du dossier et non sur tout le repertoire ???
Comment le forcer à rechercher sur tout le repertoire avec les sous dossiers ??

carlos

bonjour Carlos

j'espere que cet exempe pourra t'aider

necessite d'activer la reference Microsoft Scripting RunTime
dans l'editeur de macros
Outils
References
coches la ligne "Microsoft Scripting RunTime"
cliques sur OK pour valider



Sub listeFichiersXLS_Repertoire()
Dim Dossier As String

Dossier = "C:\Documents and Settings\michel\dossier\general\excel" 'adapter le chemin

Range("A1") = "Chemin : "
Range("B1") = "Nom : "
Range("C1") = "Date Création : "
Range("D1") = "Date Dernier Accès : "
Range("E1") = "Date Dernière Modif : "

'indiquer False pour ne pas rechercher dans les sous repertoires
ListFilesInFolder Dossier, True
End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
'necessite d'activer la reference Microsoft Scripting RunTime
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long

Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1

For Each FileItem In SourceFolder.Files

If FileItem.Type = "Feuille de calcul Microsoft Excel" Then
Cells(r, 1) = FileItem.ParentFolder
Cells(r, 2) = FileItem.Name
ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 2), Address:=FileItem.ParentFolder & "\" & FileItem.Name
Cells(r, 3) = FileItem.DateCreated
Cells(r, 3).NumberFormatLocal = "jj/mm/aa"
Cells(r, 4) = FileItem.DateLastAccessed
Cells(r, 5) = FileItem.DateLastModified
Cells(r, 5).NumberFormatLocal = "jj/mm/aa"
r = r + 1
End If

Next FileItem

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

ActiveWorkbook.Saved = True

End Sub


bon week end
MichelXld

Merci pour ta proposition

Je vais tenter de l'adapter à mes besoins

Carlos

Salut

Difficile pour moi debutant de synthetiser 2 structures de Michelxld d'ailleurs
Ca donne pour l'un:

Sub ListeFichiersXls()
Dim Fichier As String, Chemin As String
Dim LigneXls

Chemin = "C:\EPS1\" 'adapter le chemin
Fichier = Dir(Chemin & "\*.xls", 0)

'boucle sur tous les fichiers xls du repertoire
Do While Len(Fichier) > 0

'exemple d'action sur les fichiers xls :
'à adapter en fonction du projet
Open Chemin & Fichier For Input As #1
Do While Not EOF(1)
Line Input #1, LigneXls
MsgBox Fichier
Loop
Close #1

Fichier = Dir()
Loop

End Sub

Et l'autre :

Sub listeFichiersXLS_Repertoire()
Dim Dossier As String

Dossier = "C:\EPS1" '
ListFilesInFolder1 Dossier, True
End Sub

Sub ListFilesInFolder1(SourceFolderName As String, IncludeSubfolders As Boolean)

Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File


Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)

For Each FileItem In SourceFolder.Files

If FileItem.Type = "Feuille de calcul Microsoft Excel" Then

************************************************** **********
'je veux ouvrir un à un les fichiers puis remplacer le meme module
'dans chacun des fichiers

************************************************** ********
End If

Next FileItem

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

ActiveWorkbook.Saved = True

End Sub


COMMENT OUVRIR TOUS LES FICHIERS SOUS CE REPERTOIRE C\ePS1 POUR Y REMPLACER UN MODULE1 PAR UN AUTRE MODULE1 MAIS MAJ


Pas facile .......Merci

rebonjour Carlos

il ne faut pas essayer de synthetiser les 2 exemples car ils n'ont rien a voir l'un avec l'autre : ce sont des methodes totalement differentes

je ne suis pas sur d'avoir bien compris ta question , mais l'exemple ci dessous permet de remplacer tous les module1 pour ls classeurs d'un repertoire ( et sous repertoires ) , par un nouveau Module1 "C:\Module1.bas"

ATTENTION : si tu debutes en VBA , je te conseilles de faire très attention pour ne pas faire de betises sur des classeurs que tu ne souhaiterais pas modifier , car tous les "Module1" vont etre affectés !

il faut en plus activer la reference Microsoft Visual Basic for Applications Extensibility 5.3



Sub FichiersXLS_Repertoire_RemplacementModule()
Dim Dossier As String

Application.ScreenUpdating = False

Dossier = "C:\EPS1" 'adapter le chemin
ListFilesInFolder Dossier, True

Application.ScreenUpdating = True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
'necessite d'activer la reference Microsoft Scripting RunTime
'***********
'necessite d'activer la reference
'Microsoft Visual Basic for Applications Extensibility 5.3
'***********
'
' *******!!!!!!!! Attention !!!!!!!!!******************
' cet exemple remplace tous les Module1 du repertoire
'
'********************************************
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim Cible As String
Dim Wb As Workbook
Dim VBComp As Object

Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)

For Each FileItem In SourceFolder.Files

If FileItem.Type = "Feuille de calcul Microsoft Excel" Then

'************************************************* ***********
' le chemin du nouveau module à importer
Cible = "C:\Module1.bas"

'ouvrir les classeurs
Set Wb = Workbooks.Open(Filename:=SourceFolderName & "\" & FileItem.Name)

'verifie prealablement si le module existe dans le classeur ouvert
On Error Resume Next
Set VBComp = Wb.VBProject.VBComponents("Module1").CodeModule
On Error GoTo 0

If Not VBComp Is Nothing Then

With Wb.VBProject.VBComponents
.Remove .Item("Module1") 'supprime le module existant
.Import Cible 'remplace par le nouveau module
End With

End If

Wb.Close True 'refermer le classeur

'************************************************* *********
End If

Next FileItem

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

End Sub



bon apres midi
MichelXld

Re re re Bonjour MichelXld ,

Je ne sais quoi dire car ton code marche à 99% .

C'est génial pour moi

Le petit hic c'est que le module "nouvelleClasse" n'est pas supprimé et ainsi un nouveau module"NouvelleClasse1" apparait .

Quoi faire ? ou est l'erreur ?

Carlos

rebonjour Carlos

as tu bien précisé le nom du module à supprimer ?

...
With Wb.VBProject.VBComponents
.Remove .Item("nouvelleClasse") 'supprime le module existant
.Import Cible 'remplacé par le nouveau module
End With
...


bonne soiree
MichelXld

Voici le code que j'ai mis ::

Option Explicit

Sub FichiersXLS_Repertoire_RemplacementModule()
Dim Dossier As String

Application.ScreenUpdating = False

Dossier = "C:\EPS1" 'adapter le chemin
ListFilesInFolder Dossier, True

Application.ScreenUpdating = True

End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' adapté de Ole P Erlandsen
'necessite d'activer la reference Microsoft Scripting RunTime
'***********
'necessite d'activer la reference
'Microsoft Visual Basic for Applications Extensibility 5.3
'***********
'
' *******!!!!!!!! Attention !!!!!!!!!******************
' cet exemple remplace tous les Module1 du repertoire
'
'********************************************
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim Cible As String
Dim Wb As Workbook
Dim VBComp As Object

Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)

For Each FileItem In SourceFolder.Files

If FileItem.Type = "Feuille de calcul Microsoft Excel" Then

'************************************************* ***********
' le chemin du nouveau module à importer
Cible = "C:\EPS1\Module Vba Karl\NouvelleClasse.bas"

'ouvrir les classeurs
Set Wb = Workbooks.Open(Filename:=SourceFolderName & "\" & FileItem.Name)

'verifie prealablement si le module existe dans le classeur ouvert
On Error Resume Next
Set VBComp = Wb.VBProject.VBComponents("NouvelleClasse").CodeMo dule
On Error GoTo 0

If Not VBComp Is Nothing Then

With Wb.VBProject.VBComponents
.Remove .Item("NouvelleClasse") 'supprime le module existant
.Import Cible 'remplace par le nouveau module
End With

End If

Wb.Close True 'refermer le classeur

'************************************************* *********
End If

Next FileItem

If IncludeSubfolders Then
For Each SubFolder In SourceFolder.subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If

End Sub


Merci

bonjour Carlos

je sèche : apres de nouveaux essais , je ne rencontre pas ce soucis chez moi


je ne pense pas que cela change grand chose mais faute de mieux tu peux essayer

...
With Wb.VBProject.VBComponents
.Remove .Item("NouvelleClasse") 'supprime le module existant
End With
DoEvents
With Wb.VBProject.VBComponents
.Import Cible 'remplace par le nouveau module
End With
...

sinon , as tu bien activé la reference "Microsoft Visual Basic for Applications Extensibility 5.3"



bon dimanche
MichelXld

Merci pour ta tenacité...
Je vois que tu as travaillé tres tot ce matin .

Quant à mon affaire c'est le delire complet apres de tres nombreux test :

Avec un module nommé NouvelleClasse ca creer un nouveau module Nouvelles classe1 ...C'est bizarre


Avec un module du meme code mais nommé Modules1 ca semble marchait impeccable ...

Je vais tester maintenant sur plus de fichier.


tes codes semblent bons .

Merci