Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Je cherche un code qui trouve dans un rep. des classeurs contenant des macros.

Je cherche un code qui trouve dans un rep. des classeurs contenant des macros.

43 réponses
Avatar
Emile63
Bonjour a tous,

Je recherche un code qui me permettrait de lister dans un classeur,
depuis un r=E9pertoire, donn=E9 tous les fichiers (Excel + Word, serrait
encore mieux) qu'il contient et la colonne d'=E0 c=F4t=E9, s'ils comprennen=
t
des macros VBA.
Je vous remercie d'avance pour vos propositions,
Cordialement,
Emile
Signaler un problème avec ce contenu

10 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
1 2 3 4 5
Avatar
JièL
Hello

Le 20/09/2010 19:02, michdenis a écrit :
A ) Comme je ne travaille pas en réseau, je ne peux pas effectuer de test...



Si si... tu peux partager un dossier et y accéder via le nom de ta machine
ta_machinenom_partage

--
JièL / Jean-Louis GOUBERT
La FAQ Outlook est là : http://faq-outlook.fr/
Avatar
michdenis
Merci JièL... oui ça je sais... (savais...)

mais il me semble qu'il y a plus d'une manière pour indique le chemin...
Utilise-t-on toujours le chemin complet ?
Est-ce le cas pour Émile?

--
MichD
--------------------------------------------


"JièL" a écrit dans le message de groupe de discussion :
4c979cee$0$21979$
Hello

Le 20/09/2010 19:02, michdenis a écrit :
A ) Comme je ne travaille pas en réseau, je ne peux pas effectuer de test...



Si si... tu peux partager un dossier et y accéder via le nom de ta machine
ta_machinenom_partage

--
JièL / Jean-Louis GOUBERT
La FAQ Outlook est là : http://faq-outlook.fr/
Avatar
Emile63
Bonjour a tous,

Merci pour votre aide et vos solutions. ;-)
C'est vrai que ne n'ai pas indiqué le nom complet d'accès au réseau,
par souci de confidentialité.
Mais dans ma procédure originale le nom est correct, de plus, je
l'utilise dans d'autres cas de figure et il fonctionne correctement.

Depuis Excelabo, j'ai trouvé un bel exemple de Jb (que je remercie au
passage) que j'ai testé, et qui fonctionne mieux que ce que nous
avions jusqu'à présent. Il ne butte plus avec le dir, et parcours bien
les fichiers du rep. indiqué.
Je vous le copie ci-dessous, toutefois j'ai un "autre" problème :-
((( que j'explique ci-après.
A priori je souhaite qu'une procédure parcours un répertoire de mon
choix, et me liste (tous) les fichiers qui comprennent des macro VBA.
En principe je démarre d'un nouveau classeur (que j'ouvre pour
l'occasion) mais qui pourrait également s'appliquer depuis classeur en
cours, moyennant l'ajout d'un nouvel onglet. Et c'est à ce niveau que
ça "grippe" un peu.

Malheureusement, la proc. ci-dessous, écrit le nom du classeur et s'il
contient du code sur le classeur qu'il test, et non sur le classeur
prévu à cet effet. Du coup comme il referme aussitôt le fichier test é
(fich.Close SaveChanges:úlse) je perds la liste tant espérée.. :- (
'j'ai indiqué, 'ICI...' les lignes qui posent problèmes.
'*************************************************************
Function ChoixDossier()
Dim MonRepertoire As String
MonRepertoire = "Ma_machinenom_partage "
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = MonRepertoire
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
Else
ChoixDossier = InputBox("¿A partir de quel répertoire?")
End If
End Function
'*************************************************************
Sub test2()
Dim wks As Object, fich, szPath, sFil
Dim Racine As String, fs As Object, dossier_racine As Object, MiLista
As String
'Application.ScreenUpdating = False
Racine = ChoixDossier()
If Racine = "" Then Exit Sub
' ICI, je lui indique son classeur de départ.
Set nSht = Sheets.Add(Before:=Sheets(1))
On Error GoTo GesErr
DebProc: nSht.Name = "Liste fichiers"
[A1] = "Liste des fichiers du repertoire choisi"
Range("A2").Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Racine)
szPath = InputBox("Quel type de fichiers souhaites-tu lister?
(Tous=*)" & Chr(10) & _
"(Caractères gén´riques possible)", "Selection de
recherche", "*.xls")
If szPath = "" Then Exit Sub
Set wks = ThisWorkbook
sFil = Dir("*.xls")
Do While sFil <> ""
Set fich = Workbooks.Open(dossier_racine & "" & sFil)
wks.Activate
Liste (fich.Name)
fich.Close SaveChanges:úlse
sFil = Dir
Loop
Application.ScreenUpdating = True
End Sub
'*************************************************************

Sub Liste(WK$)
Dim DepLine&, FinLine&, I&, d&, AncLine&, LaProc$
Dim MonTab() As String, ModCod As Object
If Workbooks(WK).VBProject.Protection = 1& Then _
MsgBox "Accès impossible car le projet est protégé": Exit Su b
ReDim MonTab(1& To 2&, 1& To 2&)
MonTab(1&, 1&) = Workbooks(WK).FullName
MonTab(1&, 2&) = "Module"
MonTab(2&, 2&) = "Procédure"
For Each ModCod In Workbooks(WK).VBProject.VBComponents
I = UBound(MonTab, 2&) + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
With ModCod.CodeModule
MonTab(1&, I) = .Parent.Name
DepLine = .CountOfDeclarationLines
FinLine = .CountOfLines
Do
If FinLine > DepLine Then
On Error Resume Next
For I = 0& To 3&
LaProc = .ProcOfLine(DepLine + 1&, I)
AncLine = .ProcBodyLine(LaProc, I)
DepLine = DepLine + .ProcCountLines(LaProc,
I)
If Not Err.Number Then Exit For
Next I
On Error GoTo 0
I = UBound(MonTab, 2&)
If MonTab(2&, I) <> "" Then
I = I + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
End If
MonTab(2&, I) = LaProc
Else
Exit Do
End If
Loop
End With
Next
Set ModCod = Nothing
Application.ScreenUpdating = False
' ICI, il n'active pas mon classeur de départ pour écrire les
données récupérées
Worksheets("Liste fichiers").Activate
With ActiveWorkbook.ActiveSheet
d = .Range("A65536").End(xlUp).Row + 2
.Range("A" & d).Resize(UBound(MonTab, 2&), 2&) =
Application.Transpose(MonTab)
End With
Application.ScreenUpdating = True
End Sub
'*************************************************************

Encore merci pour votre aide,
Cordialement,
Emile
Avatar
michdenis
Voici un exemple :

Cette macro va lister tous les noms des fichiers qui ont du code.
Elle ne tient pas compte des fichiers dont le projetVBA est protégé
puisqu'elle ne peut pas vérifier si du code existe vraiment... on peut
modifier la macro pour qu'elle en tienne compte systématiquement
c'est à voir.

Le principe est identique pour Word, la seule différence, il faut instancier l'application
Dim Wd As Object
dim Dc as Object
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
Cette ligne deviendra : Fichier = Dir(Chemin & "*.xl*")
Fichier = Dir(Chemin & "*.Do*")
Et au lieu de la variable Wk dans le macro, tu utilises Dc
Set Dc = Wd.Documents.Open(Chemin & Fichier)

'----------------------------------------
Sub test()

Dim Chemin As String, Tblo()
Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String

Chemin = "C:UsersDMDocuments"

Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
ReDim Preserve Tblo(1 To A)
Tblo(A) = Fichier
Exit For
End If
End If
End With
Next
End If
Wk.Close False
Fichier = Dir()
Loop

With ThisWorkbook.Worksheets("Sheet1")
.Range("A1").Resize(UBound(Tblo)) = Application.Transpose(Tblo)
End With

Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
'----------------------------------------

--
MichD
--------------------------------------------


"Emile63" a écrit dans le message de groupe de discussion :

Bonjour a tous,

Merci pour votre aide et vos solutions. ;-)
C'est vrai que ne n'ai pas indiqué le nom complet d'accès au réseau,
par souci de confidentialité.
Mais dans ma procédure originale le nom est correct, de plus, je
l'utilise dans d'autres cas de figure et il fonctionne correctement.

Depuis Excelabo, j'ai trouvé un bel exemple de Jb (que je remercie au
passage) que j'ai testé, et qui fonctionne mieux que ce que nous
avions jusqu'à présent. Il ne butte plus avec le dir, et parcours bien
les fichiers du rep. indiqué.
Je vous le copie ci-dessous, toutefois j'ai un "autre" problème :-
((( que j'explique ci-après.
A priori je souhaite qu'une procédure parcours un répertoire de mon
choix, et me liste (tous) les fichiers qui comprennent des macro VBA.
En principe je démarre d'un nouveau classeur (que j'ouvre pour
l'occasion) mais qui pourrait également s'appliquer depuis classeur en
cours, moyennant l'ajout d'un nouvel onglet. Et c'est à ce niveau que
ça "grippe" un peu.

Malheureusement, la proc. ci-dessous, écrit le nom du classeur et s'il
contient du code sur le classeur qu'il test, et non sur le classeur
prévu à cet effet. Du coup comme il referme aussitôt le fichier testé
(fich.Close SaveChanges:úlse) je perds la liste tant espérée.. :-(
'j'ai indiqué, 'ICI...' les lignes qui posent problèmes.
'*************************************************************
Function ChoixDossier()
Dim MonRepertoire As String
MonRepertoire = "Ma_machinenom_partage "
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = MonRepertoire
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
Else
ChoixDossier = InputBox("¿A partir de quel répertoire?")
End If
End Function
'*************************************************************
Sub test2()
Dim wks As Object, fich, szPath, sFil
Dim Racine As String, fs As Object, dossier_racine As Object, MiLista
As String
'Application.ScreenUpdating = False
Racine = ChoixDossier()
If Racine = "" Then Exit Sub
' ICI, je lui indique son classeur de départ.
Set nSht = Sheets.Add(Before:=Sheets(1))
On Error GoTo GesErr
DebProc: nSht.Name = "Liste fichiers"
[A1] = "Liste des fichiers du repertoire choisi"
Range("A2").Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Racine)
szPath = InputBox("Quel type de fichiers souhaites-tu lister?
(Tous=*)" & Chr(10) & _
"(Caractères gén´riques possible)", "Selection de
recherche", "*.xls")
If szPath = "" Then Exit Sub
Set wks = ThisWorkbook
sFil = Dir("*.xls")
Do While sFil <> ""
Set fich = Workbooks.Open(dossier_racine & "" & sFil)
wks.Activate
Liste (fich.Name)
fich.Close SaveChanges:úlse
sFil = Dir
Loop
Application.ScreenUpdating = True
End Sub
'*************************************************************

Sub Liste(WK$)
Dim DepLine&, FinLine&, I&, d&, AncLine&, LaProc$
Dim MonTab() As String, ModCod As Object
If Workbooks(WK).VBProject.Protection = 1& Then _
MsgBox "Accès impossible car le projet est protégé": Exit Sub
ReDim MonTab(1& To 2&, 1& To 2&)
MonTab(1&, 1&) = Workbooks(WK).FullName
MonTab(1&, 2&) = "Module"
MonTab(2&, 2&) = "Procédure"
For Each ModCod In Workbooks(WK).VBProject.VBComponents
I = UBound(MonTab, 2&) + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
With ModCod.CodeModule
MonTab(1&, I) = .Parent.Name
DepLine = .CountOfDeclarationLines
FinLine = .CountOfLines
Do
If FinLine > DepLine Then
On Error Resume Next
For I = 0& To 3&
LaProc = .ProcOfLine(DepLine + 1&, I)
AncLine = .ProcBodyLine(LaProc, I)
DepLine = DepLine + .ProcCountLines(LaProc,
I)
If Not Err.Number Then Exit For
Next I
On Error GoTo 0
I = UBound(MonTab, 2&)
If MonTab(2&, I) <> "" Then
I = I + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
End If
MonTab(2&, I) = LaProc
Else
Exit Do
End If
Loop
End With
Next
Set ModCod = Nothing
Application.ScreenUpdating = False
' ICI, il n'active pas mon classeur de départ pour écrire les
données récupérées
Worksheets("Liste fichiers").Activate
With ActiveWorkbook.ActiveSheet
d = .Range("A65536").End(xlUp).Row + 2
.Range("A" & d).Resize(UBound(MonTab, 2&), 2&) Application.Transpose(MonTab)
End With
Application.ScreenUpdating = True
End Sub
'*************************************************************

Encore merci pour votre aide,
Cordialement,
Emile
Avatar
michdenis
Une variante de la macro intiale

Colonne A:A Liste de tous les fichiers Excel du répertoire
Colonne B:B Inscrit "Macro" pour les fichiers possédant du code
Les fichiers dont le code est protégé sont réputés avoir du code
dans la procédure suivante.

Nb. Certaines variables à renseigner ainsi que le nom de la feuille
où les info. seront affichés.

'--------------------------------
Sub test()

Dim Chemin As String, Tblo()
Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String, Nb As Integer
Dim FS As Object, F As Object, Ok As Boolean
Dim B As Integer

Chemin = "C:UsersDMDocuments"
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.getFolder(Chemin)
Nb = F.Files.Count
ReDim Tblo(1 To Nb, 1 To Nb)
Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ok = False
B = 1
Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
Exit For
End If
End If
End With
Next
If Ok = False Then
A = A + 1
Tblo(A, B) = Fichier
End If
Else
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
End If
Wk.Close False
Fichier = Dir()
Ok = False
Loop

With ThisWorkbook.Worksheets("Sheet1") 'Nom feuille à adapter
.Range("A2").Resize(UBound(Tblo, 1), UBound(Tblo, 2)) = Tblo
.Range("A1:B1").EntireColumn.AutoFit
With .Range("A1")
.Value = "Liste des fichiers du répertoire """ & Chemin & """ ayant du code."
.Font.Size = 14
.Font.Bold = True
End With
End With

Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'--------------------------------


--
MichD
--------------------------------------------


"michdenis" a écrit dans le message de groupe de discussion : i7cumi$ebn$
Voici un exemple :

Cette macro va lister tous les noms des fichiers qui ont du code.
Elle ne tient pas compte des fichiers dont le projetVBA est protégé
puisqu'elle ne peut pas vérifier si du code existe vraiment... on peut
modifier la macro pour qu'elle en tienne compte systématiquement
c'est à voir.

Le principe est identique pour Word, la seule différence, il faut instancier l'application
Dim Wd As Object
dim Dc as Object
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
Cette ligne deviendra : Fichier = Dir(Chemin & "*.xl*")
Fichier = Dir(Chemin & "*.Do*")
Et au lieu de la variable Wk dans le macro, tu utilises Dc
Set Dc = Wd.Documents.Open(Chemin & Fichier)

'----------------------------------------
Sub test()

Dim Chemin As String, Tblo()
Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String

Chemin = "C:UsersDMDocuments"

Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
ReDim Preserve Tblo(1 To A)
Tblo(A) = Fichier
Exit For
End If
End If
End With
Next
End If
Wk.Close False
Fichier = Dir()
Loop

With ThisWorkbook.Worksheets("Sheet1")
.Range("A1").Resize(UBound(Tblo)) = Application.Transpose(Tblo)
End With

Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
'----------------------------------------

--
MichD
--------------------------------------------


"Emile63" a écrit dans le message de groupe de discussion :

Bonjour a tous,

Merci pour votre aide et vos solutions. ;-)
C'est vrai que ne n'ai pas indiqué le nom complet d'accès au réseau,
par souci de confidentialité.
Mais dans ma procédure originale le nom est correct, de plus, je
l'utilise dans d'autres cas de figure et il fonctionne correctement.

Depuis Excelabo, j'ai trouvé un bel exemple de Jb (que je remercie au
passage) que j'ai testé, et qui fonctionne mieux que ce que nous
avions jusqu'à présent. Il ne butte plus avec le dir, et parcours bien
les fichiers du rep. indiqué.
Je vous le copie ci-dessous, toutefois j'ai un "autre" problème :-
((( que j'explique ci-après.
A priori je souhaite qu'une procédure parcours un répertoire de mon
choix, et me liste (tous) les fichiers qui comprennent des macro VBA.
En principe je démarre d'un nouveau classeur (que j'ouvre pour
l'occasion) mais qui pourrait également s'appliquer depuis classeur en
cours, moyennant l'ajout d'un nouvel onglet. Et c'est à ce niveau que
ça "grippe" un peu.

Malheureusement, la proc. ci-dessous, écrit le nom du classeur et s'il
contient du code sur le classeur qu'il test, et non sur le classeur
prévu à cet effet. Du coup comme il referme aussitôt le fichier testé
(fich.Close SaveChanges:úlse) je perds la liste tant espérée.. :-(
'j'ai indiqué, 'ICI...' les lignes qui posent problèmes.
'*************************************************************
Function ChoixDossier()
Dim MonRepertoire As String
MonRepertoire = "Ma_machinenom_partage "
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = MonRepertoire
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
Else
ChoixDossier = InputBox("¿A partir de quel répertoire?")
End If
End Function
'*************************************************************
Sub test2()
Dim wks As Object, fich, szPath, sFil
Dim Racine As String, fs As Object, dossier_racine As Object, MiLista
As String
'Application.ScreenUpdating = False
Racine = ChoixDossier()
If Racine = "" Then Exit Sub
' ICI, je lui indique son classeur de départ.
Set nSht = Sheets.Add(Before:=Sheets(1))
On Error GoTo GesErr
DebProc: nSht.Name = "Liste fichiers"
[A1] = "Liste des fichiers du repertoire choisi"
Range("A2").Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Racine)
szPath = InputBox("Quel type de fichiers souhaites-tu lister?
(Tous=*)" & Chr(10) & _
"(Caractères gén´riques possible)", "Selection de
recherche", "*.xls")
If szPath = "" Then Exit Sub
Set wks = ThisWorkbook
sFil = Dir("*.xls")
Do While sFil <> ""
Set fich = Workbooks.Open(dossier_racine & "" & sFil)
wks.Activate
Liste (fich.Name)
fich.Close SaveChanges:úlse
sFil = Dir
Loop
Application.ScreenUpdating = True
End Sub
'*************************************************************

Sub Liste(WK$)
Dim DepLine&, FinLine&, I&, d&, AncLine&, LaProc$
Dim MonTab() As String, ModCod As Object
If Workbooks(WK).VBProject.Protection = 1& Then _
MsgBox "Accès impossible car le projet est protégé": Exit Sub
ReDim MonTab(1& To 2&, 1& To 2&)
MonTab(1&, 1&) = Workbooks(WK).FullName
MonTab(1&, 2&) = "Module"
MonTab(2&, 2&) = "Procédure"
For Each ModCod In Workbooks(WK).VBProject.VBComponents
I = UBound(MonTab, 2&) + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
With ModCod.CodeModule
MonTab(1&, I) = .Parent.Name
DepLine = .CountOfDeclarationLines
FinLine = .CountOfLines
Do
If FinLine > DepLine Then
On Error Resume Next
For I = 0& To 3&
LaProc = .ProcOfLine(DepLine + 1&, I)
AncLine = .ProcBodyLine(LaProc, I)
DepLine = DepLine + .ProcCountLines(LaProc,
I)
If Not Err.Number Then Exit For
Next I
On Error GoTo 0
I = UBound(MonTab, 2&)
If MonTab(2&, I) <> "" Then
I = I + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
End If
MonTab(2&, I) = LaProc
Else
Exit Do
End If
Loop
End With
Next
Set ModCod = Nothing
Application.ScreenUpdating = False
' ICI, il n'active pas mon classeur de départ pour écrire les
données récupérées
Worksheets("Liste fichiers").Activate
With ActiveWorkbook.ActiveSheet
d = .Range("A65536").End(xlUp).Row + 2
.Range("A" & d).Resize(UBound(MonTab, 2&), 2&) Application.Transpose(MonTab)
End With
Application.ScreenUpdating = True
End Sub
'*************************************************************

Encore merci pour votre aide,
Cordialement,
Emile
Avatar
michdenis
Pour être plus précis, modifie cette ligne de code
ReDim Tblo(1 To Nb, 1 To Nb)
Par
ReDim Tblo(1 To Nb, 1 To 2)

--
MichD
--------------------------------------------


"michdenis" a écrit dans le message de groupe de discussion : i7d36a$p1f$
Une variante de la macro intiale

Colonne A:A Liste de tous les fichiers Excel du répertoire
Colonne B:B Inscrit "Macro" pour les fichiers possédant du code
Les fichiers dont le code est protégé sont réputés avoir du code
dans la procédure suivante.

Nb. Certaines variables à renseigner ainsi que le nom de la feuille
où les info. seront affichés.

'--------------------------------
Sub test()

Dim Chemin As String, Tblo()
Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String, Nb As Integer
Dim FS As Object, F As Object, Ok As Boolean
Dim B As Integer

Chemin = "C:UsersDMDocuments"
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.getFolder(Chemin)
Nb = F.Files.Count
ReDim Tblo(1 To Nb, 1 To Nb)
Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Ok = False
B = 1
Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
Exit For
End If
End If
End With
Next
If Ok = False Then
A = A + 1
Tblo(A, B) = Fichier
End If
Else
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
End If
Wk.Close False
Fichier = Dir()
Ok = False
Loop

With ThisWorkbook.Worksheets("Sheet1") 'Nom feuille à adapter
.Range("A2").Resize(UBound(Tblo, 1), UBound(Tblo, 2)) = Tblo
.Range("A1:B1").EntireColumn.AutoFit
With .Range("A1")
.Value = "Liste des fichiers du répertoire """ & Chemin & """ ayant du code."
.Font.Size = 14
.Font.Bold = True
End With
End With

Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'--------------------------------


--
MichD
--------------------------------------------


"michdenis" a écrit dans le message de groupe de discussion : i7cumi$ebn$
Voici un exemple :

Cette macro va lister tous les noms des fichiers qui ont du code.
Elle ne tient pas compte des fichiers dont le projetVBA est protégé
puisqu'elle ne peut pas vérifier si du code existe vraiment... on peut
modifier la macro pour qu'elle en tienne compte systématiquement
c'est à voir.

Le principe est identique pour Word, la seule différence, il faut instancier l'application
Dim Wd As Object
dim Dc as Object
Set Wd = CreateObject("Word.Application")
Wd.Visible = True
Cette ligne deviendra : Fichier = Dir(Chemin & "*.xl*")
Fichier = Dir(Chemin & "*.Do*")
Et au lieu de la variable Wk dans le macro, tu utilises Dc
Set Dc = Wd.Documents.Open(Chemin & Fichier)

'----------------------------------------
Sub test()

Dim Chemin As String, Tblo()
Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String

Chemin = "C:UsersDMDocuments"

Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Fichier <> ""
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
ReDim Preserve Tblo(1 To A)
Tblo(A) = Fichier
Exit For
End If
End If
End With
Next
End If
Wk.Close False
Fichier = Dir()
Loop

With ThisWorkbook.Worksheets("Sheet1")
.Range("A1").Resize(UBound(Tblo)) = Application.Transpose(Tblo)
End With

Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub
'----------------------------------------

--
MichD
--------------------------------------------


"Emile63" a écrit dans le message de groupe de discussion :

Bonjour a tous,

Merci pour votre aide et vos solutions. ;-)
C'est vrai que ne n'ai pas indiqué le nom complet d'accès au réseau,
par souci de confidentialité.
Mais dans ma procédure originale le nom est correct, de plus, je
l'utilise dans d'autres cas de figure et il fonctionne correctement.

Depuis Excelabo, j'ai trouvé un bel exemple de Jb (que je remercie au
passage) que j'ai testé, et qui fonctionne mieux que ce que nous
avions jusqu'à présent. Il ne butte plus avec le dir, et parcours bien
les fichiers du rep. indiqué.
Je vous le copie ci-dessous, toutefois j'ai un "autre" problème :-
((( que j'explique ci-après.
A priori je souhaite qu'une procédure parcours un répertoire de mon
choix, et me liste (tous) les fichiers qui comprennent des macro VBA.
En principe je démarre d'un nouveau classeur (que j'ouvre pour
l'occasion) mais qui pourrait également s'appliquer depuis classeur en
cours, moyennant l'ajout d'un nouvel onglet. Et c'est à ce niveau que
ça "grippe" un peu.

Malheureusement, la proc. ci-dessous, écrit le nom du classeur et s'il
contient du code sur le classeur qu'il test, et non sur le classeur
prévu à cet effet. Du coup comme il referme aussitôt le fichier testé
(fich.Close SaveChanges:úlse) je perds la liste tant espérée.. :-(
'j'ai indiqué, 'ICI...' les lignes qui posent problèmes.
'*************************************************************
Function ChoixDossier()
Dim MonRepertoire As String
MonRepertoire = "Ma_machinenom_partage "
If Val(Application.Version) >= 10 Then
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = MonRepertoire
.Show
If .SelectedItems.Count > 0 Then
ChoixDossier = .SelectedItems(1)
Else
ChoixDossier = ""
End If
End With
Else
ChoixDossier = InputBox("¿A partir de quel répertoire?")
End If
End Function
'*************************************************************
Sub test2()
Dim wks As Object, fich, szPath, sFil
Dim Racine As String, fs As Object, dossier_racine As Object, MiLista
As String
'Application.ScreenUpdating = False
Racine = ChoixDossier()
If Racine = "" Then Exit Sub
' ICI, je lui indique son classeur de départ.
Set nSht = Sheets.Add(Before:=Sheets(1))
On Error GoTo GesErr
DebProc: nSht.Name = "Liste fichiers"
[A1] = "Liste des fichiers du repertoire choisi"
Range("A2").Select
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set dossier_racine = fs.getfolder(Racine)
szPath = InputBox("Quel type de fichiers souhaites-tu lister?
(Tous=*)" & Chr(10) & _
"(Caractères gén´riques possible)", "Selection de
recherche", "*.xls")
If szPath = "" Then Exit Sub
Set wks = ThisWorkbook
sFil = Dir("*.xls")
Do While sFil <> ""
Set fich = Workbooks.Open(dossier_racine & "" & sFil)
wks.Activate
Liste (fich.Name)
fich.Close SaveChanges:úlse
sFil = Dir
Loop
Application.ScreenUpdating = True
End Sub
'*************************************************************

Sub Liste(WK$)
Dim DepLine&, FinLine&, I&, d&, AncLine&, LaProc$
Dim MonTab() As String, ModCod As Object
If Workbooks(WK).VBProject.Protection = 1& Then _
MsgBox "Accès impossible car le projet est protégé": Exit Sub
ReDim MonTab(1& To 2&, 1& To 2&)
MonTab(1&, 1&) = Workbooks(WK).FullName
MonTab(1&, 2&) = "Module"
MonTab(2&, 2&) = "Procédure"
For Each ModCod In Workbooks(WK).VBProject.VBComponents
I = UBound(MonTab, 2&) + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
With ModCod.CodeModule
MonTab(1&, I) = .Parent.Name
DepLine = .CountOfDeclarationLines
FinLine = .CountOfLines
Do
If FinLine > DepLine Then
On Error Resume Next
For I = 0& To 3&
LaProc = .ProcOfLine(DepLine + 1&, I)
AncLine = .ProcBodyLine(LaProc, I)
DepLine = DepLine + .ProcCountLines(LaProc,
I)
If Not Err.Number Then Exit For
Next I
On Error GoTo 0
I = UBound(MonTab, 2&)
If MonTab(2&, I) <> "" Then
I = I + 1&
ReDim Preserve MonTab(1& To 2&, 1& To I)
End If
MonTab(2&, I) = LaProc
Else
Exit Do
End If
Loop
End With
Next
Set ModCod = Nothing
Application.ScreenUpdating = False
' ICI, il n'active pas mon classeur de départ pour écrire les
données récupérées
Worksheets("Liste fichiers").Activate
With ActiveWorkbook.ActiveSheet
d = .Range("A65536").End(xlUp).Row + 2
.Range("A" & d).Resize(UBound(MonTab, 2&), 2&) Application.Transpose(MonTab)
End With
Application.ScreenUpdating = True
End Sub
'*************************************************************

Encore merci pour votre aide,
Cordialement,
Emile
Avatar
Emile63
On 15 sep, 19:02, Emile63 wrote:
Bonjour MichDenis,

Merci beaucoup pour ton aide, après quelques réglages et adaptations,
finalement ça tourne.
:-))

Par rapport à ce que tu m'explique au sujet de "Word", J'ai compris
que je devrais faire une seconde procédure en changeant ce que tu
m'indiques.
Mais est-ce qu'il y a une possibilité de tout faire avec la même
procédure?
Merci pour ta solicitude,
Cordialement,

Emile
Avatar
michdenis
Un exemle : tu lances la macro "Liste_Fichiers_Excel_Word_Avec_Macro"
Quelques variables à définir :
Le répertoire de ton choix
le nom de la feuille où seront copiées les données

'------------------------------------
Sub Liste_Fichiers_Excel_Word_Avec_Macro()
Dim Tblo(), Chemin As String, DerLig As Long

Chemin = "C:UsersDMDocuments" 'à déterminer

Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") 'Nom feuille à adapter
Call Fichiers_Excel_Avec_Macro(Chemin, Tblo())
.Range("A3").Resize(UBound(Tblo, 1), UBound(Tblo, 2)) = Tblo
Erase Tblo
Call Fichiers_Word_Avec_Macro(Chemin, Tblo())
DerLig = .Range("A65536").End(xlUp).Row + 2
With Range("A" & DerLig)
.Value = "Liste des fichiers ""Word"" avec macro"
.Font.Size = 14
.Font.Bold = True
End With
.Range("A" & DerLig + 1).Resize(UBound(Tblo, 1), UBound(Tblo, 2)) = Tblo
.Range("A1:B1").EntireColumn.AutoFit
With .Range("A1")
.Value = "Liste des fichiers du répertoire """ & Chemin & """ ayant du code."
.Font.Size = 14
.Font.Bold = True
End With
With .Range("A2")
.Value = "Liste des fichiers ""Excel"" avec macro"
.Font.Size = 14
.Font.Bold = True
End With
End With
Application.ScreenUpdating = True
End Sub

'---------------------------------------
Sub Fichiers_Excel_Avec_Macro(Chemin As String, Tblo())

Dim Fichier As String, A As Integer
Dim Wk As Workbook, Comp As Object
Dim ModCalcul As String, Nb As Integer
Dim FS As Object, F As Object, Ok As Boolean
Dim B As Integer

Chemin = "C:UsersDMDocuments"
Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.getFolder(Chemin)
Nb = F.Files.Count
ReDim Tblo(1 To Nb, 1 To 2)
Fichier = Dir(Chemin & "*.xl*")
ModCalcul = Application.Calculation
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Ok = False
B = 1
Do While Fichier <> ""
If UCase(ThisWorkbook.FullName) <> UCase(Chemin & Fichier) Then
Set Wk = Workbooks.Open(Chemin & Fichier)
If Wk.VBProject.Protection = False Then
For Each Comp In Wk.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
Exit For
End If
End If
End With
Next
If Ok = False Then
A = A + 1
Tblo(A, B) = Fichier
End If
Else
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
End If
Wk.Close False
Fichier = Dir()
Ok = False
End If
Loop
Set FS = Nothing: Set F = Nothing
Set Wk = Nothing: Set Comp = Nothing
Application.DisplayAlerts = True
Application.Calculation = ModCalcul
Application.EnableEvents = True
End Sub

'---------------------------------------
Sub Fichiers_Word_Avec_Macro(Chemin As String, Tblo())

Dim Wd As Object, DC As Object, Nb As Integer
Dim Fichier As String, A As Integer
Dim Comp As Object, B As Integer
Dim FS As Object, F As Object, Ok As Boolean

Set FS = CreateObject("Scripting.FileSystemObject")
Set F = FS.getFolder(Chemin)
Nb = F.Files.Count
ReDim Tblo(1 To Nb, 1 To 2)
Set Wd = CreateObject("Word.Application")
Fichier = Dir(Chemin & "*.do*")
Ok = False
B = 1
Do While Fichier <> ""
If Chemin & Fichier <> ThisWorkbook.FullName Then
Set DC = Wd.Documents.Open(Chemin & Fichier)
If DC.VBProject.Protection = False Then
For Each Comp In DC.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0 Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
Exit For
End If
End If
End With
Next
If Ok = False Then
A = A + 1
Tblo(A, B) = Fichier
End If
Else
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro"
Ok = True
End If
DC.Close False
Fichier = Dir()
Ok = False
End If
Loop
Wd.Quit
Set Wd = Nothing: Set DC = Nothing
Set FS = Nothing: Set F = Nothing
End Sub
'---------------------------------------
Avatar
Emile63
Bonjour MichDenis,

Je te remercie pour ton aide et pour cette solution. :-))
Après adaptations ça tourne. :-)
J'ai toutefois une petite erreur. La liste des documents Word générée
ne présentent aucune macro, alors qu'il y en a...
Dans le pas-à-pas, je crois deviner qu'il ne détecte pas le module
VBA, puisqu'il ne compte aucune ligne (0) depuis la comande:
If .countOflines > 0
-Est-ce que dans Word ce sont les mêmes noms d'objet que dans Excel
(CodeModule etc..) ??

'--------------------------------------------
For Each Comp In DC.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0
Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro" ' N'en ramène
aucune.. :-(
Ok = True
Exit For
End If
End If
End With
Next
'--------------------------------------------------

Je te remercie d'avance pour ta solicitude,
Très cordialement,
Emile
Avatar
michdenis
J'ai refait un test ce matin, et, la liste des fichiers Word avec Macro
correspond bien à ce qu'il y a dans le répertoire. La détection est
systématique que le code soit dans le ThisDocument ou dans un
module standard du projetVBA de Word.

Le modèle objet de Word est bien différent de celui d'Excel. Mais
concernant la gestion des modules, elle est très similaire.

Tester à partir de Word 2007.


--
MichD
--------------------------------------------


"Emile63" a écrit dans le message de groupe de discussion :

Bonjour MichDenis,

Je te remercie pour ton aide et pour cette solution. :-))
Après adaptations ça tourne. :-)
J'ai toutefois une petite erreur. La liste des documents Word générée
ne présentent aucune macro, alors qu'il y en a...
Dans le pas-à-pas, je crois deviner qu'il ne détecte pas le module
VBA, puisqu'il ne compte aucune ligne (0) depuis la comande:
If .countOflines > 0
-Est-ce que dans Word ce sont les mêmes noms d'objet que dans Excel
(CodeModule etc..) ??

'--------------------------------------------
For Each Comp In DC.VBProject.VBComponents
With Comp.CodeModule
If .countOflines > 0 Then
Text = .Lines(1, .countOflines)
If InStr(1, Text, "Sub", vbTextCompare) > 0 Or _
InStr(1, Text, "Function", vbTextCompare) > 0
Then
A = A + 1
Tblo(A, B) = Fichier
Tblo(A, B + 1) = "Macro" ' N'en ramène
aucune.. :-(
Ok = True
Exit For
End If
End If
End With
Next
'--------------------------------------------------

Je te remercie d'avance pour ta solicitude,
Très cordialement,
Emile
1 2 3 4 5