|
 Posté le 10/12/2014 @ 16:52 |
Petit astucien
| bonjour le forum,
je cherche à obtenir la liste des fichiers (répartis dans différents sous-dossiers) qui contiennent une certaine chaîne de caractères dans leur module standard (et autres tant qu'à faire : classe, userform).
exemple concret : parmi la centaine de fichiers dans mon arborescence, je sais que j'ai utilisé le terme "ArrayList" dans le module standard de certains de ces fichiers, mais lesquels ?
j'ai essayé : - la barre de recherche de l'explorateur (Windows 7), sans succès - celle d'Excel (2010), quand on est dans la fenêtre "Ouvrir", mais qui ne cherche que dans les feuilles, et non les modules. - Google, qui ne me proposait que des méthodes pour chercher du texte dans des feuilles
s'il n'y a pas de méthode ad hoc, peut-être que qqn a développé un code VBA permettant de faire ça ? car je ne dois pas être le premier à tenter ce type de recherche.
|
|
|
|
|
|
Posté le 11/12/2014 à 16:15 |
| |
|
Posté le 11/12/2014 à 16:41 |
| ce qui pourrait donner un truc du genre à condition d'ouvrir les classeurs à traiter
Sub Rechercher()
Dim Classeur As Workbook Dim Module As Object Dim Rechercher As String Dim Remplacer As String Dim Trouver As Integer Dim I As Integer
'Le module où se trouve cette proc 'doit s'appeler "ModuleDeMiseAJour" afin qu'aucune modif ne soit faite 'dans cette proc Rechercher = "ArrayList" For Each Classeur In Workbooks For Each Module In Classeur.VBProject.VBComponents With Module.CodeModule If Module.Name = "ModuleDeMiseAJour" Then GoTo sortie For I = 1 To .CountOfLines Trouver = InStr(.Lines(I, 1), Rechercher) If Trouver > 0 Then 'si une occurrence est trouvée, fait la modif et boucle 'sur la ligne afin de remplacer tous les mots
MsgBox "mot trouvé dans :" & Classeur.Name & " " & Module.Name End If Next I sortie: 'End If End With
Next Module Next Classeur Set Classeur = Nothing Set Module = Nothing End Sub |
|
Posté le 12/12/2014 à 15:13 |
Petit astucien
| merci Gilbert,
c'est une piste très intéressante pour la partie identification de la chaine de texte dans les modules ; je prends ! 
il me reste à ajouter le code qui va m'ouvrir tous les fichiers XL d'une arborescence (dossiers et sous dossiers). un p'tit coup de pouce là dessus ? |
|
Posté le 12/12/2014 à 15:33 |
| Code à mettre dans un module standard
en feuille1 nommer 3 cellules
ExtFich => A3
Titre => D3
DebListe =>D4
mettre en feuille 1 et en cellule a3 (ExtFich) l'extension des fichiers à lister ex : xl* pour les fichiers excel
lancer la macro ci-dessous puis choisir le répertoire
la liste des fichiers sera affichée en feuille 1 colonne D avec un entête indiquant le nombre de fichiers listés
ensuite il faut faire une boucle qui ouvre et qui ferme les fichiers 
ça devrait pouvoir fonctionner bon courage le plus dure est trouvé 
Public ledos As String Public msg As String
Function ChoixDossier(chemin) Dim objShell, objFolder
Set objShell = CreateObject("Shell.Application")
'Cette Ligne = pour afficher seulement les répertoires Set objFolder = objShell.BrowseForFolder(&H0&, msg, &H1&, chemin) On Error Resume Next chemin = objFolder.parentFolder.ParseName(objFolder.Title).Path & "" ledos = chemin '(.parentFolder)
End Function Sub ListeFichier() Dim xxx As String Dim FichX As String Dim tabFich() As String Dim i As Integer Dim j As Integer Dim esp As Integer Dim z As String Dim x As String Dim CheminEtFichier As String Dim SourceFile, DestinationFile Application.ScreenUpdating = False 'x = "essai" msg = "Choisissez votre répertoire source :" ledossier = Path CheminEtFichier = ChoixDossier(ledossier) z = ledos xxx = Worksheets("Fichiers").Range("ExtFich").Value ReDim tabFich(1) tabFich(0) = Dir(z & "\*." & xxx) If tabFich(0) = "" Then MsgBox "Aucun Document d'extension " & xxx & " dans le dossier en cours." Exit Sub End If i = 1 Do While True ReDim Preserve tabFich(i + 1) tabFich(i) = Dir() If tabFich(i) = "" Then Exit Do i = i + 1 Loop ActiveSheet.Range("DebListe").Select Selection.CurrentRegion.Select Selection.ClearContents 'supp_chek For j = 0 To i - 1 ActiveSheet.[Titre].Value = i & " FICHIERS " & UCase(xxx) ActiveSheet.[DebListe].Offset(j, 0).Value = tabFich(j) ActiveSheet.[DebListe].Offset(j, -1).Select Next ActiveSheet.[Titre].Select
Application.ScreenUpdating = True MsgBox "La liste des fichiers est copiée" End Sub Modifié par gilbert_rgi le 12/12/2014 15:37 |
|
Posté le 12/12/2014 à 17:59 |
Petit astucien
| merci beaucoup, tu as bien défriché le terrain.
je vais tester tout ça et adapter à mon besoin (vais probablement mettre un peu de temps pour revenir confirmer que c'est résolu, mais je n'y manquerai pas).
et en prime je mettrai le code que j'aurai adapté pour mon besoin, si ça peut servir à d'autres. |
|
Posté le 15/01/2015 à 16:21 |
Petit astucien
| bonjour,
après pas mal de recherchessss complémentairessss, je suis finalement arrivé à un code qui fait ce que je voulais. voici le résultat pour ceux qui cherchent à faire comme moi.
le scénario : - je saisis la chaîne de texte à chercher dans les modules de code VBA (avec ou sans respect de la casse), puis choisis le dossier où chercher cette chaîne - le code parcourt le dossier défini, et tous ses sous-dossiers (sur une profondeur de 5 niveaux dans l'arborescence), puis stocke dans une collection le chemin de tous les fichiers xls* rencontrés (y a possibilité d'utiliser une méthode récursive, mais je ne maîtrise pas du tout, j'ai donc fait un gros pâté tout moche avec mes _N1, _N2, etc.) - une boucle ouvre chaque fichier de la liste, et recherche la chaîne de texte dans chaque module de code ; si la chaîne est présente, le nom complet (avec chemin) du fichier est stocké dans une collection - enfin, la liste des fichiers contenant la chaîne est collé sur une feuille vierge (je viens de réaliser que je n'ai pas encore géré le cas où aucune correspondance n'est trouvée, ça affiche une feuille vide tout simplement)
(le code est indenté mais j'ai pas réussi à maintenir l'indentation dans mon message) ====================================================================================================
'choix de la chaîne de texte à chercher et du dossier de recherche TITRE_MSGBOX = "Recherche script VBA" CHAINE_TXT = InputBox(vbLf & "Chaîne à chercher ?", TITRE_MSGBOX): If CHAINE_TXT = Empty Then Exit Sub OPTION_CASSE = IIf(MsgBox("Respecter la casse ?", vbQuestion + vbYesNo, TITRE_MSGBOX) = vbYes, vbBinaryCompare, vbTextCompare) Set OBJ_SYSTEME = CreateObject("Shell.Application") Set DOSSIER_RECHERCHE = OBJ_SYSTEME.BrowseForFolder(&H0&, "Choisir le dossier de recherche", &H1, "") If DOSSIER_RECHERCHE Is Nothing Then MsgBox "Dossier de recherche non sélectionné.", vbCritical, TITRE_MSGBOX: Exit Sub Else CHEMIN = DOSSIER_RECHERCHE.ParentFolder.ParseName(DOSSIER_RECHERCHE.Title).Path End If
'listing des fichiers à scanner (5 niveaux de profondeur dans l'arborescence) Set LISTE_FICHIERS = CreateObject("System.Collections.ArrayList") Set OBJ_SYSTEME = CreateObject("Scripting.FileSystemObject") Set DOSSIER_RECHERCHE = OBJ_SYSTEME.Getfolder(CHEMIN) Set FICHIERS = DOSSIER_RECHERCHE.Files: GoSub CREATION_LISTE_FICHIERS Set SOUS_DOSSIERS_N1 = DOSSIER_RECHERCHE.SubFolders For Each SOUS_DOSS_N1 In SOUS_DOSSIERS_N1 Set FICHIERS = SOUS_DOSS_N1.Files: GoSub CREATION_LISTE_FICHIERS Set SOUS_DOSSIERS_N2 = SOUS_DOSS_N1.SubFolders For Each SOUS_DOSS_N2 In SOUS_DOSSIERS_N2 Set FICHIERS = SOUS_DOSS_N2.Files: GoSub CREATION_LISTE_FICHIERS Set SOUS_DOSSIERS_N3 = SOUS_DOSS_N2.SubFolders For Each SOUS_DOSS_N3 In SOUS_DOSSIERS_N3 Set FICHIERS = SOUS_DOSS_N3.Files: GoSub CREATION_LISTE_FICHIERS Set SOUS_DOSSIERS_N4 = SOUS_DOSS_N3.SubFolders For Each SOUS_DOSS_N4 In SOUS_DOSSIERS_N4 Set FICHIERS = SOUS_DOSS_N4.Files: GoSub CREATION_LISTE_FICHIERS Set SOUS_DOSSIERS_N5 = SOUS_DOSS_N4.SubFolders For Each SOUS_DOSS_N5 In SOUS_DOSSIERS_N5 Set FICHIERS = SOUS_DOSS_N5.Files: GoSub CREATION_LISTE_FICHIERS Next SOUS_DOSS_N5 Next SOUS_DOSS_N4 Next SOUS_DOSS_N3 Next SOUS_DOSS_N2 Next SOUS_DOSS_N1 GoTo SUITE CREATION_LISTE_FICHIERS: For Each FICH In FICHIERS If LCase(Mid(FICH, InStrRev(FICH, ".") + 1, 3)) = "xls" Then LISTE_FICHIERS.Add CStr(FICH) Next FICH Return
'ouverture/scan des fichiers et création liste résultat SUITE: LISTE_FICHIERS.Sort: NB_FICHIERS = LISTE_FICHIERS.Count Set LISTE_RESULTAT = CreateObject("System.Collections.ArrayList") For i = 1 To NB_FICHIERS Application.StatusBar = "Scan fichier... " & i & "/" & NB_FICHIERS Workbooks.Open filename:=LISTE_FICHIERS(i - 1), ReadOnly:=True: Set FICHIER_ANALYSE = ActiveWorkbook For Each MODULE In FICHIER_ANALYSE.VBProject.VBComponents With MODULE.CodeModule If .CountOfLines > 0 Then BINGO = InStr(1, .Lines(1, .CountOfLines), CHAINE_TXT, OPTION_CASSE) Else BINGO = 0 End With If BINGO > 0 Then LISTE_RESULTAT.Add FICHIER_ANALYSE.FullName: Exit For End If Next MODULE: Windows(FICHIER_ANALYSE.Name).Close savechanges:=False Next i Workbooks.Add: ActiveSheet.Name = "Résultat" For i = 1 To LISTE_RESULTAT.Count Cells(i, 1).Formula = LISTE_RESULTAT(i - 1) Next i Application.StatusBar = False
|
|