Exceldatei per Eingabefeld nach Inhalt durchsuchen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo!
Teste mal folgenden Code, beachte aber die u.a. Voraussetzungen:

Sub a()
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Tabelle1")
Dim WbQ As Workbook, Ws As Worksheet
Dim Pfad$, Datei$, Such$, Treffer As Range, Felder, i&
Dim Hl As Range, f As Boolean: f = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show  -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1) & "\"
End If
End With
Application.ScreenUpdating = False
Such = "Test"
Datei = Dir(Pfad & "*.xls*", vbDirectory)
Felder = Array("A1", "B2", "C3", "D4", "E5")
Do Until Dir = vbNullString
Set WbQ = Workbooks.Open(Datei)
For Each Ws In WbQ.Worksheets
Set Treffer = Ws.UsedRange.Find(Such, LookIn:=xlValues, _
lookat:=xlWhole)
If Not Treffer = Nothing Then
f = True: Exit For
End If
Next Ws
If f Then
With WsZ
For i = LBound(Felder) To UBound(Felder)
.Cells(.Rows.Count, i + 1).End(xlUp).Offset(1, 0) = _
WbQ.Worksheets(1).Range(Felder(i)).Offset(, 1)
Next i
Set Hl = .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0)
Hl.Hyperlinks.Add anchor:=Hl, Address:=Pfad & Datei
End With
WbQ.Close False
Else:
WbQ.Close False
End If
Datei = Dir
Loop
Set WbZ = Nothing: Set WsZ = Nothing: Set WbQ = Nothing
Set Ws = Nothing: Set Treffer = Nothing: Erase Felder
Set Hl = Nothing
End Sub

Voraussetzungen:
- Das Makro wird aus der Mappe aufgerufen, in der die Übersicht erstellt werden soll; das Tabellenblatt heißt bei mir "Tabelle1" (ggf. anpassen)
- Die Überschriftenzeile (Projektname, etc.) ist bereits auf dem Blatt vorhanden
- Gesucht wird in den Dateien immer nach dem Begriff der hier definiert wird

Such = "Test"

- Ich gehe davon aus, dass die Rubriken (Projektname etc.) immer in den gleichen Zellen stehen, auf dem ersten Tabellenblatt; hier werden diese Zellen vordefiniert - übertragen wird dann ggf. der Wert der in der Zelle rechts daneben steht (wie von Dir angegeben):

Felder = Array("A1", "B2", "C3", "D4", "E5")

- Code lässt sich von mir schlecht testen, weil ich mir Deine Dateiablage etc. nicht nachbaue(n kann).
Gib Bescheid!
Michael

Sub a() Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Tabelle1") Dim WbQ As Workbook, Ws As Worksheet Dim Pfad$, Datei$, Such$, Treffer As Range, Felder, i& Dim Hl As Range, f As Boolean: f = False With Application.FileDialog(msoFileDialogFolderPicker) .Title = "Bitte Verzeichnis wählen" .AllowMultiSelect = False If .Show -1 Then MsgBox "Vorgang abgebrochen", vbInformation Exit Sub Else: Pfad = .SelectedItems(1) & "\" End If End With Application.ScreenUpdating = False Such = "Hallo" Datei = Dir(Pfad & "*.xls*", vbDirectory) Felder = Array("A1", "B2", "C3", "D4", "E5") Do Until Datei = vbNullString Set WbQ = Workbooks.Open(Pfad & Datei) For Each Ws In WbQ.Worksheets Set Treffer = Ws.UsedRange.Find(what:=Such, LookIn:=xlValues, _ lookat:=xlWhole, searchorder:=xlByRows, _ searchdirection:=xlNext, MatchCase:=True, _ searchformat:=False) If Not Treffer Is Nothing Then f = True: Exit For End If Set Treffer = Nothing Next Ws If f Then With WsZ For i = LBound(Felder) To UBound(Felder) .Cells(.Rows.Count, i + 1).End(xlUp).Offset(1, 0) = _ WbQ.Worksheets(1).Range(Felder(i)).Offset(, 1) Next i Set Hl = .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) Hl.Hyperlinks.Add anchor:=Hl, Address:=Pfad & Datei End With WbQ.Close False Else: WbQ.Close False End If f = False Datei = Dir Loop Set WbZ = Nothing: Set WsZ = Nothing: Set WbQ = Nothing Set Ws = Nothing: Set Treffer = Nothing: Erase Felder Set Hl = Nothing End Sub

Do Until Dir = vbNullString Set WbQ = Workbooks.Open(Pfad & Datei) For Each Ws In WbQ.Worksheets Set Treffer = Ws.UsedRange.Find(what:=Such, LookIn:=xlValues, _ lookat:=xlWhole, searchorder:=xlByRows, _ searchdirection:=xlNext, MatchCase:=True, _ searchformat:=False) If Not Treffer Is Nothing Then f = True: Exit For End If Set Treffer = Nothing Next Ws If f Then With WsZ For i = LBound(Felder) To UBound(Felder) .Cells(.Rows.Count, i + 1).End(xlUp).Offset(1, 0) = _ WbQ.Worksheets(1).Range(Felder(i)).Offset(, 1) Next i Set Hl = .Cells(.Rows.Count, 6).End(xlUp).Offset(1, 0) Hl.Hyperlinks.Add anchor:=Hl, Address:=Pfad & Datei End With WbQ.Close False Else: WbQ.Close False End If Datei = Dir Loop

Hallo Codex,
...ich weiß schon mal, dass Du nicht exakt meinen zuletzt geposteten Code verwendest.
Zunächst ist diese Zeile schlicht falsch

Do Until Dir = vbNullString

wie Du an meinem oben geposteten Code leicht erkennen kannst:

Do Until Datei = vbNullString

Außerdem fehlen Dir noch andere Codeteile meines zweiten Codes von oben. Ich weiß also nicht, was Du Dir da zusammenkopierst; so, wie ich den zweiten Code geschrieben haben verwendest Du ihn offenbar nicht.
Im Gegensatz zu meinem ersten Code ist mein zweiter mit einer Handvoll Dateien und zwei unterschiedlichen Verzeichnissen getestet; funktioniert bei mir, gem. Deiner Angaben, einwandfrei. Aber ich habe ja schon erwähnt, dass ich auf Deine konkreten Gegebenheiten schwer testen kann, da unbekannt.
Wie gesagt, aus meiner Sicht arbeitet mein zweiter Code korrekt; ich tue mir jetzt schwer Dir hier ferndiagnostisch zu helfen.
LG
Michael

Beliebteste Forumthreads (12 Monate)

Exceldatei per Eingabefeld nach Inhalt durchsuchen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Exceldatei per Eingabefeld nach Inhalt durchsuchen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread