'*********************************************************************************************
'* *
'* Projektierung und Realisierung *
'* durch *
'* Oliver Scheckelhoff *
'*
http://www.excelbeispiele.de *
'* info@excelbeispiele.de *
'* *
'* *
'* ####### #### #### ######## ####### ### *
'* ######## #### #### ######### ######## ### *
'* ### #### #### ### ### ### *
'* ######## ####### ## ######## ### *
'* ######## ####### ## ######## ### *
'* ### #### ###### ### ### ### *
'* ######## #### #### ######### ######## ######## *
'* ####### #### ####### ######## ####### ####### beispiele.de *
'* *
'* © 2007 Copyright Oliver Scheckelhoff, Alle Rechte vorbehalten *
'* *
'* Diese Datei unterliegt dem Urhebergesetz und ist somit Eigentum von *
'* Oliver Scheckelhoff *
'* *
'* Jegliches Verändern der Datei oder des VBA-Codes ist strengstens verboten. *
'* Zuwiderhandlung wird strafrechtlich verfolgt *
'* *
'*********************************************************************************************
Option Explicit
Dim Obj As Object
Dim Dateien As Object
Dim Durchläufe As Object
Dim Dateityp As Object
Sub Auflistung_start()
Dim strPfad As String
Dim i As Integer
'Pfad auswählen
strPfad = GetDirectory("Bitte Ordner auswählen") & "\"
'Wenn kein Pfad ausgewählt, Prozdur beenden
If strPfad = "\" Or strPfad = "" Then Exit Sub
'Falls Backslash feht, diesen anhängen
If Len(strPfad) = 4 Then strPfad = Mid(strPfad, 1, 3)
On Error GoTo Ende
'For/ Next-Schleife zum Prüfen ob Bltt "Auswertung bereits existiert
For i = 1 To Worksheets.Count
'Wenn durch die Schleife abgefragter Blattname gleich "Auflistung", dann...
If Sheets(i).Name = "Auflistung" Then
'... Meldungen deaktivieren
Application.DisplayAlerts = False
'Blatt "Auflistung" löschen und...
Sheets(i).Delete
'... Meldungen wieder aktivieren und...
Application.DisplayAlerts = True
'...Schleife beenden
Exit For
End If
Next
'Neues Tabellenblatt mit dem Namen "Auflistung" erstellen
With Worksheets.Add
.Name = "Auflistung"
End With
'Verweis Obj setzen
Set Obj = CreateObject("Scripting.FileSystemObject")
'Verweis Dateien setzen
Set Dateien = Obj.getfolder(strPfad)
'Makro Auflistung ausführen
Call Auflistung
Ende:
End Sub
Sub Auflistung()
Dim i As Integer
'Bildschirmaktualisierung deaktivieren
Application.ScreenUpdating = False
'Schleife zum Durchlaufen des ausgewählten Verzeichnisses
For Each Dateityp In Dateien.Files
If Right(Dateityp.Name, 4) = "ma.xls" Then _
'**********
'**********
'**********Hier möchte ich nicht die Hyperlinks sondern den Inhalt
'**********des Bereichs A1-B3 aller ma.xls Dateien aufgelistet haben!!!!
Workbooks.Open "Dateityp.files"
Range(A1, [B3]).Copy
Workbooks.Close
'**********
'**********
'**********
End If
Next
'Schleife um Unterverzeichnisse durchzulaufen
For Each Durchläufe In Dateien.subfolders
Set Dateien = Durchläufe
Call Auflistung
Next
Sheets("Auflistung").Columns("A:A").EntireColumn.AutoFit
End Sub
