Excel Downloads
Forum

Précédent   Excel Downloads Forums > Excel > Forum Excel


Réponse
 
LinkBack Outils de la discussion
Vieux 14/03/2005, 22h05   #1 (permalink)
tyuiop
Guest
 
Messages: n/a
Par défaut reperer les classeur avec une macro

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
  Réponse avec citation
Vieux 15/03/2005, 00h12   #2 (permalink)
XLDnaute Barbatruc
 
Avatar de myDearFriend!
 
Date d'inscription: février 2005
Messages: 2 284
Par défaut Re:reperer les classeur avec une macro

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').GetFold er(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]
Fichiers attachés
Type de fichier : zip TestMacrosClasseurs.zip (15,0 Ko, 0 affichages)
__________________
Didier_mDF

www.mdf-xlpages.com
myDearFriend! est déconnecté   Réponse avec citation
ANNONCES
Réponse

Liens sociaux

Outils de la discussion

Règles de messages
Vous ne pouvez pas créer de nouvelles discussions
Vous ne pouvez pas envoyer des réponses
Vous ne pouvez pas envoyer des pièces jointes
Vous ne pouvez pas modifier vos messages

Les balises BB sont activées : oui
Les smileys sont activés : oui
La balise [IMG] est activée : oui
Le code HTML peut être employé : non
Trackbacks are oui
Pingbacks are oui
Refbacks are oui


Fuseau horaire GMT +2. Il est actuellement 07h29.


(C) 2006 Excel Downloads