Top-Themen

Aktuelle Themen (A bis Z)

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, 3335 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 ..
Ähnliche Inhalte
VB for Applications
Excel Makros
Frage von chaos2goVB for Applications2 Kommentare

Hallo Gemeinde, File Größe über 500k Einträge Steigend . ich bekomme Monatlich ein Raw Dump aus unserer DB als ...

VB for Applications
Brauche dringend Hilfe in Excel Makros
gelöst Frage von StefanHVB for Applications4 Kommentare

Hallo allerseits, ich hoffe ihr könnt mir helfen. Meine Excel-Makro Kenntnisse gehen gegen null und ich soll nun was ...

Microsoft Office
Excel 2010 Doc Properties ohne Makros
Frage von arduinoMicrosoft Office1 Kommentar

Moin Erstmal ein gutes neues Jahr allerseits. Kennt jemand eine Möglichkeit, in Excel 2010 Custom Doc Properties z.B. in ...

Microsoft Office
Excel 2010 - Tabelle mit mehreren Makros?
Frage von Norderney95Microsoft Office2 Kommentare

Ich brauche jeden Monat eine Arbeitsmappe (wie in der angehängten Datei), die folgendes enthält - 1. Blatt „Summe“ - 2. Blatt ...

Neue Wissensbeiträge
Verschlüsselung & Zertifikate

Die Hölle friert ein weiteres Stück zu: Microsoft integriert OpenSSH in Windows

Information von ticuta1 vor 21 MinutenVerschlüsselung & Zertifikate

Interessant SSH-Kommando in CMD.exe und PowerShell

Apple

IOS 11.2.1 stopft HomeKit-Remote-Lücke

Tipp von BassFishFox vor 1 TagApple

Das Update für iPhone, iPad und Apple TV soll die Fernsteuerung von Smart-Home-Geräten wieder in vollem Umfang ermöglichen. Apple ...

Windows 10

Windows 10 v1709 EN murkst bei den Regionseinstellungen

Tipp von DerWoWusste vor 1 TagWindows 10

Dieser kurze Tipp richtet sich an den kleinen Personenkreis, der Win10 v1709 EN-US frisch installiert und dabei die englische ...

Webbrowser

Kein Ton bei Firefox Quantum über RDP

Tipp von Moddry vor 1 TagWebbrowser

Hallo Kollegen! Hatte das Problem, dass der neue Firefox bei mir auf der Kiste keinen Ton hat, wenn ich ...

Heiß diskutierte Inhalte
Windows Server
RODC kann nicht aus Domäne entfernt werden
Frage von NilsvLehnWindows Server18 Kommentare

HAllo, ich arbeite in einem Universitätsnetzwerk mit 3 Standorten. Die Standorte haben alle ein ESXi Cluster und auf diesen ...

Hardware
Kein Bild mit nur einer bestimmten Grafikkarten - Mainboard Konfiguration
gelöst Frage von bestelittHardware18 Kommentare

Hallo zusammen, ich hatte schon einmal eine ähnliche Frage gestellt. Damals hatte ich genau das gleiche Problem. Allerdings lies ...

Netzwerkmanagement
Mehrere Netzwerkadapter in einem PC zu einem Switch zusammenfügen
Frage von prodriveNetzwerkmanagement17 Kommentare

Hallo zusammen Vorweg, ich konnte schon einige IT-Probleme mit Hilfe dieses Forums lösen. Wirklich klasse hier! Doch für das ...

Hardware
Links klick bei Maus funktioniert nicht
gelöst Frage von Pablu23Hardware16 Kommentare

Hallo erstmal. Ich habe ein Problem mit meiner relativ alten maus jedoch denke ich nicht das es an der ...