AW: Suchen in bestimmten Zellen von mehreren Dateien
06.05.2009 15:10:12
mehreren
AUA .. böses Foul, hatte doch die Close Anweisung so geschrieben, dass sie nur für Treffer gilt. ^^
Habe ich geändert und da ich gerade dabei war, habe ich auch die Möglichkeit eingebaut das Du entweder nach Suchbegriff 1 oder nach Suchbegriff 1 UND 2 suchen kannst. Willst du nur nach Suchbegriff 1 suchen, dann lass einfach Eingaben Suchbegriff 2 leer und drück OK.
Zum Thema Anzeige im Arbeitsblatt ... ich habe das ActiveSheet als Ausgabe angewählt gehabt. Hab es nun so gemacht, dass immer das erste Sheet in der Mappe in der das Makro drinnen ist als Ausgabesheet angewählt ist. Bei mir funktioniert es auf jeden Fall ... probiere es jetzt nochmal aus und gib Rückmeldung ob es jetzt auch die Ausgabe anzeigt.
Hier nochmal der komplette Code:
Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" ( _
ByVal pidl As Long, _
ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" ( _
lpBrowseInfo As BROWSEINFO) As Long
Function OrdnerAuswahl() As String
Dim bInfo As BROWSEINFO
Dim strPath As String
Dim lngR As Long
Dim lngX As Long
Dim intPos As Integer
bInfo.pidlRoot = 0&
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus"
bInfo.ulFlags = &H1
lngX = SHBrowseForFolder(bInfo)
strPath = Space$(512)
lngR = SHGetPathFromIDList(ByVal lngX, ByVal strPath)
If lngR Then
intPos = InStr(strPath, Chr$(0))
OrdnerAuswahl = Left(strPath, intPos - 1)
Else
OrdnerAuswahl = ""
End If
End Function
Sub OrdnerLesen()
Dim fso As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fDateien As Object
Dim sPfad As String
Dim sSuche As String
Dim sSuche2 As String
Dim sMappe As String
Dim cMappe As String
Dim i As Integer
On Error GoTo Err_Handler
' Suchbegriff 1 eingeben
sSuche = InputBox _
("Bitte geben Sie den ersten zu suchenden Begriff ein: ", "Suchbegriff")
' Suchbegriff checken
If sSuche = "" Then
MsgBox "Sie haben keinen ersten Suchbegriff eingeben!"
Exit Sub
End If
' Suchbegriff 2 eingeben
sSuche2 = InputBox _
("Bitte geben Sie den zweiten zu suchenden Begriff ein: ", "Suchbegriff")
' Suchbegriff 2 nicht checken, da er ruhig leer bleiben kann
' Ordner in dem gesucht werden soll festlegen
sPfad = OrdnerAuswahl & "\"
' Objects setzen
Set fso = CreateObject("Scripting.FileSystemObject")
Set fVerz = fso.GetFolder(sPfad)
Set fDateien = fVerz.Files
' Ausgabebereich resetten
i = 10
With ActiveSheet
Do Until .Cells(i, 1).Value = ""
.Cells(i, 1).ClearContents
i = i + 1
Loop
End With
' Jede Mappe lesen, dann öffnen und im Sheet "Arbeitskarte" Zelle A1 + L8 prüfen ob Suchstring _
1/2 beinhaltet
For Each fDatei In fDateien
Workbooks.Open Filename:=fDatei
' FullName in Variabele lesen
sMappe = ActiveWorkbook.FullName
cMappe = ActiveWorkbook.Name
'Klären ob nach einem oder nach zwei Kriterien gesucht werden soll
If sSuche2 > "" Then GoTo ZweierVergleich
' Ein Kriterium in A1 checken
If InStr(ActiveWorkbook.Sheets("Arbeitskarte").Range("A1"), sSuche) > 0 Then
' dieses Workbook und Tabellenblatt 1 aktivieren
ThisWorkbook.Activate
Sheets(1).Activate
' FullName in aktives Sheet schreiben
With ActiveSheet
.Range("A10").Select
Selection.EntireRow.Insert
ActiveCell.Value = sMappe
End With
End If
' Wenn Einservergleich durchlaufen, dann ZweierVergleich überspringen
GoTo Weiter
ZweierVergleich:
' Kriterium in A1 und Kriterium 2 in L8 checken
If InStr(ActiveWorkbook.Sheets("Arbeitskarte").Range("A1"), sSuche) > 0 And _
InStr(ActiveWorkbook.Sheets("Arbeitskarte").Range("L8"), sSuche2) Then
' dieses Workbook und Tabellenblatt 1 aktivieren
ThisWorkbook.Activate
Sheets(1).Activate
' FullName in aktives Sheet schreiben
With ActiveSheet
.Range("A10").Select
Selection.EntireRow.Insert
ActiveCell.Value = sMappe
End With
End If
Weiter:
Workbooks(cMappe).Close SaveChanges:=False
Next fDatei
Exit Sub
Err_Handler:
MsgBox "Es tratt folgender Fehler auf: " & Err.Number & vbLf & _
Err.Description
End Sub
Gruß
Rainer