Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Makros in vielen Excel Dokumenten finden

Frage Microsoft Microsoft Office

Mitglied: djbazo

djbazo (Level 1) - Jetzt verbinden

29.12.2010 um 12:01 Uhr, 3297 Aufrufe, 14 Kommentare

Eine Möglichkeit eine Auswertung durchzuführen, die mir alle Excel Dateien, die VBA / Markos enthalten auflistet.

Hallo zusammen,

ich habe in einem anderen Forum bereits einen Ansatz gefunden, der leider etwas veraltet ist (Office 2000).
Könnte man einem Anfänger vielleicht den Stoß in die richtige Richtung geben? Ich selbst benutze Office 2007

01.
Option Explicit 
02.
 
03.
Sub VbaCodeInDateienSuchen() 
04.
   Dim strStartOrdner As String, i As Long 
05.
    
06.
   strStartOrdner = "E:\test" 
07.
    
08.
   With Application.FileSearch 
09.
      .NewSearch 
10.
      .FileType = msoFileTypeExcelWorkbooks 
11.
      .Filename = "*.xl?" 
12.
      .LookIn = strStartOrdner 
13.
      .SearchSubFolders = True 
14.
      .Execute 
15.
      For i = 1 To .FoundFiles.Count 
16.
         Application.StatusBar = "Teste Datei " & i & " von " & .FoundFiles.Count 
17.
         Cells(i, 1).Value = .FoundFiles(i) 
18.
         Cells(i, 2).Value = HasMacros(.FoundFiles(i)) 
19.
      Next 
20.
      Application.StatusBar = False 
21.
   End With 
22.
End Sub 
23.
 
24.
Private Function HasMacros(ByVal strFileName As String) As String 
25.
   Dim bHasCode As Boolean, bOpen As Boolean, vbc As Object 
26.
   On Error GoTo ERR_File 
27.
    
28.
   bHasCode = False 
29.
   Application.EnableEvents = False 
30.
   Application.ScreenUpdating = False 
31.
   Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True, Password:="", WriteResPassword:="", AddToMru:=False 
32.
   For Each vbc In ActiveWorkbook.VBProject.VBComponents 
33.
      If vbc.CodeModule.CountOfLines > 2 Then ' Option Explicit & eine Leerzeile lassen wir mal zu ... 
34.
         bHasCode = True 
35.
         Exit For 
36.
      End If 
37.
   Next 
38.
   HasMacros = CStr(bHasCode) 
39.
    
40.
ERR_File: 
41.
   If Err.Number Then HasMacros = Err.Description 
42.
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False 
43.
   Application.ScreenUpdating = True 
44.
   Application.EnableEvents = True 
45.
End Function 

Vielleicht hat jemand aber auch einen ganz anderen Ansatz?

Vielen Dank schonmal
Mitglied: 76109
29.12.2010 um 12:30 Uhr
Hallo djbazo!

Welches Betriebssystem?

Ab Windows 7 wird bei mir der Zugriff aus Sicherheitsgründen verweigert. Liegt womöglich an den Office-Sicherheits-Updates?

Gruß Dieter

PS. Mach mal testweise ein Kommentarzeichen vor das "On Error..."
Bitte warten ..
Mitglied: djbazo
29.12.2010 um 13:52 Uhr
Hallo Dieter,

danke für die Antwort. Setze VISTA Enterprise ein.

Bei mir kommt bei Ausführung:

Laufzeitfehler '445'
Objekt unterstützt diese Aktion nicht

-> den onError habe ich in Kommentar gesetzt
Bitte warten ..
Mitglied: 76109
29.12.2010 um 14:19 Uhr
Hallo djbazo!

Und bleibt der Debugger in Codezeile 32 oder 33 stehen?

Gruß Dieter
Bitte warten ..
Mitglied: djbazo
29.12.2010 um 14:44 Uhr
Hallo Dieter,

er bleibt in Codezeile 8 mit dem Fehler stehen

Grüße
Bitte warten ..
Mitglied: 76109
29.12.2010 um 14:47 Uhr
Hallo djbazo!

Habe ich wohl etwas geschlafen

Ab Version 2007 gibt es die Application FileSearch nicht mehr. Es gibt allerdings eine Alternative dazu, aber den Schnippsel muß ich erst suchen!

Gruß Dieter
Bitte warten ..
Mitglied: 76109
29.12.2010 um 15:08 Uhr
Hallo djbazo!

Alternativ zu Application.FileSearch in etwa so:
01.
Option Compare Text 
02.
 
03.
Const StartFolder = "E:\Test"  'Hauptverzeichnis 
04.
 
05.
Dim Fso As Object 
06.
 
07.
Sub Main 
08.
   '.... 
09.
    Set Fso = CreateObject("Scripting.FileSystemObject") 
10.
 
11.
    Call SearchExcelFiles(Fso.GetFolder(StartFolder)) 
12.
   '.... 
13.
    MsgBox "Fertig!" 
14.
End Sub 
15.
 
16.
Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen 
17.
    Dim File As Object, SubFolder As Object 
18.
     
19.
    For Each File In Folder.Files 
20.
        If Fso.GetExtensionName(File.Name) Like "xl*" Then 
21.
            Call OpenAndTestWorkbook(File.Path) 
22.
        End If 
23.
    Next 
24.
     
25.
    For Each SubFolder In Folder.SubFolders 
26.
        Call SearchExcelFiles(SubFolder) 
27.
    Next 
28.
End Sub 
29.
 
30.
Private Sub OpenAndTestWorkbook(ByRef Path) 
31.
   'Dein Workbook-Code 
32.
End Sub
Gruß Dieter
Bitte warten ..
Mitglied: djbazo
29.12.2010 um 15:40 Uhr
danke, das läuft durch ohne Fehler.
jetzt muss ich nur noch die beiden Codes zusammenfriemeln verstehe ich das richtig (sorry - im a newby)
Bitte warten ..
Mitglied: 76109
29.12.2010 um 15:58 Uhr
Hallo djbazo!

In meinem Code wird die "Sub OpenAndTestWorkbook" für jede gefundene Datei (Path ist Dateipfad) einzeln aufgerufen. Insofern kannst Du hier alles reinpacken

Der Makro-Start erfolgt dann über die Sub "Main" (Name nach belieben).

Den Zähler i musst Du allerdings in der Codezeile 5 mit definieren und in der Sub "Main" vor Codezeile 11 auf 1 setzen und in der Sub "OpenAndTestWorkbook" nach dem Eintrag in die entsprechenden Zellen hochzählen ( i = i +1) .

Gruß Dieter
Bitte warten ..
Mitglied: djbazo
29.12.2010 um 16:10 Uhr
Sorry Dieter - ich versteh gerade nur Bahnhof
Kannst du mir weiterhelfen, denn so klappts nicht:

01.
Option Compare Text 
02.
 
03.
Const StartFolder = "E:\Test"  'Hauptverzeichnis 
04.
 
05.
Dim Fso As Object 
06.
 
07.
Sub Main 
08.
   '.... 
09.
    Set Fso = CreateObject("Scripting.FileSystemObject") 
10.
 
11.
    Call SearchExcelFiles(Fso.GetFolder(StartFolder)) 
12.
   '.... 
13.
    MsgBox "Fertig!" 
14.
End Sub 
15.
 
16.
Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen 
17.
    Dim File As Object, SubFolder As Object 
18.
     
19.
    For Each File In Folder.Files 
20.
        If Fso.GetExtensionName(File.Name) Like "xl*" Then 
21.
            Call OpenAndTestWorkbook(File.Path) 
22.
        End If 
23.
    Next 
24.
     
25.
    For Each SubFolder In Folder.SubFolders 
26.
        Call SearchExcelFiles(SubFolder) 
27.
    Next 
28.
End Sub 
29.
 
30.
Private Sub OpenAndTestWorkbook(ByRef Path) 
31.
   'Dein Workbook-Code 
32.
   Dim bHasCode As Boolean, bOpen As Boolean, vbc As Object 
33.
    
34.
   bHasCode = False 
35.
   Application.EnableEvents = False 
36.
   Application.ScreenUpdating = False 
37.
   Workbooks.Open strFileName, UpdateLinks:=False, ReadOnly:=True, Password:="", WriteResPassword:="", AddToMru:=False 
38.
   For Each vbc In ActiveWorkbook.VBProject.VBComponents 
39.
      If vbc.CodeModule.CountOfLines > 2 Then ' Option Explicit & eine Leerzeile lassen wir mal zu ... 
40.
         bHasCode = True 
41.
         Exit For 
42.
      End If 
43.
   Next 
44.
   HasMacros = CStr(bHasCode) 
45.
End Sub
Bitte warten ..
Mitglied: 76109
29.12.2010 um 16:56 Uhr
Hallo djbazo!

Versuchs mal so:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
Const StartFolder = "E:\Test"  'Hauptverzeichnis 
05.
 
06.
Dim Fso As Object, FileCount As Long 
07.
 
08.
Sub Start() 
09.
    Set Fso = CreateObject("Scripting.FileSystemObject") 
10.
 
11.
    FileCount = 1 
12.
 
13.
    Call SearchExcelFiles(Fso.GetFolder(StartFolder)) 
14.
     
15.
    MsgBox "Fertig!" 
16.
End Sub 
17.
 
18.
Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen 
19.
    Dim File As Object, SubFolder As Object 
20.
     
21.
    For Each File In Folder.Files 
22.
        If Fso.GetExtensionName(File.Name) Like "xl*" Then 
23.
            Call OpenAndTestWorkbook(File.Path) 
24.
        End If 
25.
    Next 
26.
     
27.
    For Each SubFolder In Folder.SubFolders 
28.
        Call SearchExcelFiles(SubFolder) 
29.
    Next 
30.
End Sub 
31.
 
32.
Private Sub OpenAndTestWorkbook(ByRef Path) 
33.
   Dim vbc As Object, MacroCode As Boolean 
34.
    
35.
   With Application 
36.
        .EnableEvents = False 
37.
        .ScreenUpdating = False 
38.
   End With 
39.
    
40.
   'On Error GoTo ERR_File 
41.
    
42.
   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True 
43.
    
44.
   For Each vbc In ActiveWorkbook.VBProject.VBComponents 
45.
     'Option Explicit & eine Leerzeile lassen wir mal zu ... 
46.
      If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For 
47.
   Next 
48.
    
49.
ERR_File: 
50.
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False 
51.
    
52.
   Cells(FileCount, 1).Value = Path 
53.
 
54.
   If Err.Number Then 
55.
        Cells(FileCount, 2).Value = Err.Description 
56.
   Else 
57.
        Cells(FileCount, 2).Value = MacroCode 
58.
   End If 
59.
 
60.
   FileCount = FileCount + 1 
61.
    
62.
   With Application 
63.
        .ScreenUpdating = True 
64.
        .EnableEvents = True 
65.
   End With 
66.
End Sub
Gruß Dieter
Bitte warten ..
Mitglied: djbazo
03.01.2011 um 15:22 Uhr
Hallo Dieter,

noch ein gutes Neues.
Gleich zum Start auch noch so eine super Lösung die perfekt funktioniert.

Vielen Dank. Alle Daumen nach oben!!

Man kann sogar den Kommentar von On Error entfernen dann überspringt er sogar Dokumente mit geschützten Zellen....

01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
Const StartFolder = "E:\Test"  'Hauptverzeichnis 
05.
 
06.
Dim Fso As Object, FileCount As Long 
07.
 
08.
Sub Start() 
09.
    Set Fso = CreateObject("Scripting.FileSystemObject") 
10.
 
11.
    FileCount = 1 
12.
 
13.
    Call SearchExcelFiles(Fso.GetFolder(StartFolder)) 
14.
     
15.
    MsgBox "Fertig!" 
16.
End Sub 
17.
 
18.
Private Sub SearchExcelFiles(ByRef Folder)  'Alle Dateien in Start- und Unterordner suchen 
19.
    Dim File As Object, SubFolder As Object 
20.
     
21.
    For Each File In Folder.Files 
22.
        If Fso.GetExtensionName(File.Name) Like "xl*" Then 
23.
            Call OpenAndTestWorkbook(File.Path) 
24.
        End If 
25.
    Next 
26.
     
27.
    For Each SubFolder In Folder.SubFolders 
28.
        Call SearchExcelFiles(SubFolder) 
29.
    Next 
30.
End Sub 
31.
 
32.
Private Sub OpenAndTestWorkbook(ByRef Path) 
33.
   Dim vbc As Object, MacroCode As Boolean 
34.
    
35.
   With Application 
36.
        .EnableEvents = False 
37.
        .ScreenUpdating = False 
38.
   End With 
39.
    
40.
   On Error GoTo ERR_File 
41.
    
42.
   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True 
43.
    
44.
   For Each vbc In ActiveWorkbook.VBProject.VBComponents 
45.
     'Option Explicit & eine Leerzeile lassen wir mal zu ... 
46.
      If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For 
47.
   Next 
48.
    
49.
ERR_File: 
50.
   If Not ThisWorkbook Is ActiveWorkbook Then ActiveWorkbook.Close False 
51.
    
52.
   Cells(FileCount, 1).Value = Path 
53.
 
54.
   If Err.Number Then 
55.
        Cells(FileCount, 2).Value = Err.Description 
56.
   Else 
57.
        Cells(FileCount, 2).Value = MacroCode 
58.
   End If 
59.
 
60.
   FileCount = FileCount + 1 
61.
    
62.
   With Application 
63.
        .ScreenUpdating = True 
64.
        .EnableEvents = True 
65.
   End With 
66.
End Sub

DANKE!!
Bitte warten ..
Mitglied: 76109
03.01.2011 um 15:52 Uhr
Hallo djbazo!

Yepp, gern geschehen

Wünsche auch ein gutes neues Jahr!

Gruß Dieter
Bitte warten ..
Mitglied: djbazo
04.01.2011 um 13:32 Uhr
Hallo Dieter,

nun ist mir doch noch etwas aufgefallen.
Sobald eine Datei einen Leseschutz hat kommt die Passwortabfrage.
Diese breche ich generell ab und überspringe somit die Datei.

Hast du einen kleinen Kniff, wie das per Script umgesetzt werden kann?

Grüße
Bitte warten ..
Mitglied: 76109
04.01.2011 um 15:55 Uhr
Hallo djbazo!

Sollte so gehen:
01.
'Snip...................................... 
02.
 
03.
Private Sub OpenAndTestWorkbook(ByRef Path) 
04.
   Dim vbc As Object, MacroCode As Boolean 
05.
    
06.
   With Application 
07.
        .EnableEvents = False 
08.
        .ScreenUpdating = False 
09.
   End With 
10.
    
11.
   On Errror Resume Next    'Fehlerbehandlung deaktivieren 
12.
 
13.
   Workbooks.Open Path, UpdateLinks:=False, ReadOnly:=True 
14.
    
15.
   If Err.Number = 0 Then   
16.
       For Each vbc In ActiveWorkbook.VBProject.VBComponents 
17.
         'Option Explicit & eine Leerzeile lassen wir mal zu ... 
18.
          If vbc.CodeModule.CountOfLines > 2 Then MacroCode = True:  Exit For 
19.
       Next 
20.
    
21.
       ActiveWorkbook.Close False 
22.
    
23.
       Cells(FileCount, 2).Value = MacroCode 
24.
   Else 
25.
       Cells(FileCount, 2).Value = Err.Description:   
26.
   End If	    
27.
     
28.
  'On Error Goto 0     
29.
  'Würde die Fehlerbehandlung für den Rest-Code bis End Sub wieder aktivieren 
30.
    
31.
   Cells(FileCount, 1).Value = Path 
32.
 
33.
   FileCount = FileCount + 1 
34.
    
35.
   With Application 
36.
        .ScreenUpdating = True 
37.
        .EnableEvents = True 
38.
   End With 
39.
End Sub
Gruß Dieter
Bitte warten ..
Neuester Wissensbeitrag
Humor (lol)

Linkliste für Adventskalender

(3)

Information von nikoatit zum Thema Humor (lol) ...

Ähnliche Inhalte
Microsoft Office
Excel 2010 - Tabelle mit mehreren Makros? (2)

Frage von Norderney95 zum Thema Microsoft Office ...

Microsoft Office
Darstellung einer Produktionsmenge in einer Excel Übersicht! (4)

Frage von Magnus32x1 zum Thema Microsoft Office ...

Batch & Shell
gelöst Loginzeiten aus dem Ereignisprotokoll in Excel schreiben (1)

Frage von l-Ne0n zum Thema Batch & Shell ...

Microsoft Office
gelöst Excel SUMIF sozusagen (2)

Frage von PharIT zum Thema Microsoft Office ...

Heiß diskutierte Inhalte
Windows Server
DHCP Server switchen (24)

Frage von M.Marz zum Thema Windows Server ...

SAN, NAS, DAS
gelöst HP-Proliant Microserver Betriebssystem (14)

Frage von Yannosch zum Thema SAN, NAS, DAS ...

Grafikkarten & Monitore
Win 10 Grafikkarte Crash von Software? (13)

Frage von Marabunta zum Thema Grafikkarten & Monitore ...

Windows 7
Verteillösung für IT-Raum benötigt (12)

Frage von TheM-Man zum Thema Windows 7 ...