reperer les classeur avec une macro

  • Initiateur de la discussion tyuiop
  • Date de début
T

tyuiop

Guest
Qui saurai comment rechercher parmis tous les classeurs xls ceux qui contienent une macro en VBA ?

Je suis un peu désordre et j'aimerais séparer les classeurs sans macro et les claseurs avec.

Merci d'avance
 

myDearFriend!

XLDnaute Barbatruc
Bonsoir tyuiop

(azert... ? :) )


Tu trouveras ci-joint un fichier pouvant peut-être répondre à ton problème...

'ATTENTION : nécessite une référence à la librairie
'Microsoft Visual Basic For Applications Extensibility 5.3
'

Private Function ContientMacros(Classeur As Workbook) As Boolean
Dim Obj As Object
      For Each Obj In Classeur.VBProject.VBComponents
            With Obj.CodeModule
                  ContientMacros = .CountOfDeclarationLines + 1 < .CountOfLines
            End With
            If ContientMacros Then Exit For
      Next Obj
End Function

Sub TestClasseurs()
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String
Dim L As Long
      Application.ScreenUpdating = False
      CeFichier = ThisWorkbook.Name
      'Chemin du dossier à analyser (à adapter au besoin)
      Chemin = ThisWorkbook.Path & '\'
      'Analyse du dossier
      L = 1
      Set Dossier = CreateObject('Scripting.FileSystemObject').GetFolder(Chemin)
      For Each Fichier In Dossier.Files
            If Fichier.Name <> CeFichier Then
                  'Liste les fichiers Excel en précisant s'ils contiennent des macros
                  If Right(Fichier.Name, 3) = 'xls' Then
                        L = L + 1
                        Workbooks.Open Chemin & Fichier.Name
                        With ThisWorkbook.Sheets('Test')
                              .Cells(L, 2) = Fichier.Name
                              .Cells(L, 1) = IIf(ContientMacros(ActiveWorkbook), 'OUI', '')
                        End With
                        ActiveWorkbook.Close False
                  End If
            End If
      Next
      Set Dossier = Nothing
      Application.ScreenUpdating = True
      MsgBox L & ' classeurs trouvés !'
End Sub


Cordialement. [file name=TestMacrosClasseurs.zip size=15397]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/TestMacrosClasseurs.zip[/file]
 

Pièces jointes

  • TestMacrosClasseurs.zip
    15 KB · Affichages: 55

Discussions similaires

Réponses
19
Affichages
547

Statistiques des forums

Discussions
312 196
Messages
2 086 101
Membres
103 116
dernier inscrit
kutobi87