AW: Bestimmte Excel-Dateien auflisten
24.11.2008 12:01:46
fcs
Hallo Hüseyin,
hier auch noch mein Vorschlag.
Das zu durchsuchende Verzeichnis und der Filter für die Dateien werden dabei vom Makro abgefragt.
Die Ergebnisausgabe erfolgt in eine neues Tabellenblatt und in eien Msgox.
Gruß
Franz
'# Dateien auf Wert in Zelle H2 prüfen #
'# Ersteller: fcs #
'# Datum : 2008-11-23 #
'# Excelversion: 97 SP 2 #
Option Explicit
Sub Check_H2()
Dim varVerzeichnis, objFileSearch As FileSearch, intI, objWb As Workbook
Dim strMsg, intDatei As Integer, varErgebnis, strFilter As String
Dim intCount As Integer, lngZeile As Long
Dim objWks As Worksheet
Const strZelle As String = "H2" 'Auszuwertende Zelle
Const varWert = "X" 'Prüfwert
Const varTabelle = 1 'Nummer oder Name der zu Prüfenden Tabelle
On Error GoTo Fehler
'zu durchsuchendes Verzeichnis auswählen ### Name des Startverzeichnisses anpssen!!
varVerzeichnis = fncDateiAuswahl(strVerzeichnis:="C:\Eigene Dateien\Test\Daten", _
strTitel:="Zur Verzeichnis-Auswahl Datei wählen und öffnen", _
bolDatei:=False)
If varVerzeichnis = False Then GoTo Beenden
'Filter für Dateisuche eingeben
strFilter = VBA.InputBox(Prompt:="Bitte Filter für Dateisuche im Verzeichnis" _
& vbLf & vbLf & varVerzeichnis & vbLf & vbLf & "eingeben", _
Title:="Filter für Dateisuche", Default:="*.xls")
If strFilter = "" Then GoTo Beenden
'Dateien suchen und auswerten
Set objFileSearch = Application.FileSearch
With objFileSearch
.NewSearch
.LookIn = varVerzeichnis
.FileName = strFilter
.SearchSubFolders = False
If .Execute > 0 Then
Application.ScreenUpdating = False
'Tabellenblatt einfügen für Ergebnisausgabe
ActiveWorkbook.Worksheets.Add
Set objWks = ActiveSheet
'Spaltentitel eintragen
With objWks
lngZeile = 1
.Cells(lngZeile, 1) = "Verzeichnis:"
.Cells(lngZeile, 2) = varVerzeichnis
lngZeile = 2
.Cells(lngZeile, 1) = "Filter:"
.Cells(lngZeile, 2) = strFilter
lngZeile = 3
.Cells(lngZeile, 1) = "Nummer"
.Cells(lngZeile, 2) = "Dateiname"
.Cells(lngZeile, 3) = "Wert " & strZelle
End With
'Fenster unter Spaltentiteln fixieren
Cells(lngZeile + 1, 1).Select
ActiveWindow.FreezePanes = True
'Dateien auswerten
For intDatei = 1 To .FoundFiles.Count
'Statusmeldung für Arbeitsfortschritt
Application.StatusBar = "Datei " & intDatei & " von " & .FoundFiles.Count _
& " wird ausgewertet, Dateiname: " & .FoundFiles(intDatei)
'Datei schreibgeschützt öffnen
Set objWb = Application.Workbooks.Open(FileName:=.FoundFiles(intDatei), _
ReadOnly:=True)
'Wert aus Zelle in Tabelle auslesen
varErgebnis = objWb.Worksheets(varTabelle).Range(strZelle).Value
'Dateiname und Wert in Zelle in Tabellenblatt eintragen
lngZeile = lngZeile + 1
objWks.Cells(lngZeile, 1) = intDatei
objWks.Cells(lngZeile, 2) = objWb.Name
objWks.Cells(lngZeile, 3) = varErgebnis
If LCase(varErgebnis) = LCase(varWert) Then
'Meldetext um Dateinamen ergänzen
intCount = intCount + 1
strMsg = strMsg & vbLf & intCount & " : " & .FoundFiles(intDatei)
End If
Resume01:
objWb.Close savechanges:=False
Set objWb = Nothing
Next
'Im Ausgabetabellenblatt
With objWks
'Spalten formatieren
.Range(.Columns(1), .Columns(3)).EntireColumn.AutoFit
.Columns(3).EntireColumn.HorizontalAlignment = xlHAlignCenter
'Zählenformel einfügen in Zelle C2
.Range("C2").Formula = "=COUNTIF(" & .Range(.Cells(4, 3), _
.Cells(lngZeile, 3)).Address(ReferenceStyle:=xlR1C1) & ",""X"")"
End With
Application.StatusBar = False
Application.ScreenUpdating = True
'Ergebnis in Messagebox ausgeben
If strMsg "" Then
strMsg = "Auswertung Zelle H2 in Dateien:" & vbLf & strMsg
MsgBox strMsg, vbOKOnly, "Liste Dateien mit " & varWert & " in Zelle " _
& strZelle
Else
MsgBox "Auswertung Zelle H2 in Dateien:" & vbLf & vbLf _
& "Keine Dateien mit " & varWert & " in Zelle " _
& strZelle & " gefunden!", vbOKOnly, "Liste Dateien mit " & varWert _
& " in Zelle " & strZelle
End If
Else
MsgBox strMsg & vbLf & vbLf & "Keine Dateien für Filter """ & strFilter & """" _
& vbLf & "in Verzeichnis """ & varVerzeichnis & """", _
vbOKOnly, "Liste Dateien mit """ & varWert & """ in Zelle " & strZelle
End If
End With
Beenden:
'Fehlerbehandlung
Fehler:
With Err
If .Number 0 Then
Select Case .Number
Case 13 ' Typen unverträglich - Zellenauswertung liefert Fehler-Wert
Resume Resume01
Case Else
MsgBox "Fehler-Nr. " & .Number & vbLf & .Description
End Select
If Not objWb Is Nothing Then objWb.Close savechanges:=False
Application.StatusBar = False
Application.ScreenUpdating = True
End If
End With
End Sub
Public Function fncDateiAuswahl(Optional strVerzeichnis As String, _
Optional strFilter As String = "Excel(*.xls),*.xls", _
Optional strTitel As String = "Bitte zu öffnende Datei wählen", _
Optional bolMultiselect As Boolean = False, _
Optional bolVerzeichniswechseln As Boolean = False, _
Optional bolDatei As Boolean = True)
'Funktion ermöglicht entsprechend den gewählten Parametern die Auswahl eines _
Verzeichnisses oder von Dateien im Datei-Öffnen-Dialogdenster
' strVerzeichnis = Startverzeichnis für Dateiauswahl
' strFilter = Filter für auswählbare Dateien
' strTitel = "Titel des Dialogfensters
' bolMultiselect = Multiselektion Ja/Nein
' bolVerzeichniswechseln = Ja/Mein ;True: Das gewählte Verzeichnis wird zum aktiven _
Verzeichnis
' bolDatei = Ja/Nein; False: Nur das gewählte Verzeichnis wird als Wert zurückgegeben
Dim varAuswahl, strVerzAktiv As String
On Error GoTo Fehler
If bolVerzeichniswechseln = False Then
'Aktuelles Verzeichnis merken
strVerzAktiv = VBA.CurDir
End If
If strVerzeichnis "" Then
'In vorgegbenen Verzeichnis wechseln
VBA.ChDir strVerzeichnis
End If
'Dateiauswahl-Dialog anzeigen
varAuswahl = Application.GetOpenFilename(Filefilter:=strFilter, _
Title:=strTitel, MultiSelect:=bolMultiselect)
If bolDatei = True Then
'Dateiauswahl an Funktionswert übergeben
fncDateiAuswahl = varAuswahl
Else
'Aktives Verzeichnis an Funktionswert übergeben
If varAuswahl = False Then
fncDateiAuswahl = False
Else
fncDateiAuswahl = VBA.CurDir
End If
End If
If bolVerzeichniswechseln = False Then
'gemerktes Verzeichnis wieder einstellen
VBA.ChDir strVerzAktiv
End If
'Fehlerbehandlung
Fehler:
With Err
If .Number 0 Then
MsgBox "fehler-Nr. " & .Number & vbLf & .Description & vbLf _
& vbLf & "Vorgegebenes Verzeichnis """ & strVerzeichnis & """ existiert nicht!"
Resume Next
End If
End With
End Function