AW: Blattinhalte kopieren
25.10.2017 13:44:17
fcs
Hallo Axel,
ich hab dein Makro jetzt mal erweitert und angepasst.
Nach der Eingabe des Suchbegriffs, können die zu durchsuchenden Dateien in einem Dateiauswahldialog ausgewählt werden.
Die ausgewählten Dateien werden dann in einer Schleife abgearbeit.
Vor der Ausgabe der Trefferliste wird gefragt ob weitere Dateien durchsucht werden sollen.
Im Auswerteblatt wird jetzt zusätzlich der Suchbegriff und der Name der Datei ausgegeben.
Hoffe, das trifft jetzt deine Wunschliste.
Gruß
Franz
Sub Suchen_und_Anzeigen_neu()
Dim Meldung As Byte, Pos As Byte
Dim Schleife As Byte, y As Byte
Dim Begriff, Suchen() As Variant
Dim Bereich As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), xWorkbook$(), Text$
Dim arrWkb As Variant, varWkb, wkb As Workbook
Dim wksAnzeige As Worksheet
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Wert eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
x = 1 'Zähler für gefundene Zellen
DateiAuswahl:
'zu durchsuchende Datei(en) auswählen
arrWkb = Application.GetOpenFilename( _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
Title:="Bitte zu durchsuchende Datei(en) auswählen", _
MultiSelect:=True)
If Not IsArray(arrWkb) Then Exit Sub
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
For Each varWkb In arrWkb
Set wkb = Workbooks.Open(Filename:=varWkb, ReadOnly:=True)
For y = 1 To Schleife
For n = 1 To wkb.Sheets.Count
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = wkb.Worksheets(n).UsedRange
With wkb.Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With wkb.Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
ReDim Preserve xWorkbook(x)
xWorkbook(x) = wkb.Name
xTabelle(x) = wkb.Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address ErsteAdresse
End If
End With
Next n
Next y
wkb.Close savechanges:=False
Next varWkb
Application.ScreenUpdating = True
If MsgBox("Weitere Dateien nach dem Suchbegriff """ & Begriff _
& """ durchsuchen?", vbYesNo + vbQuestion, "S U C H M O D U S") = vbYes Then _
GoTo DateiAuswahl
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
vbOKOnly, "G E F U N D E N E W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Es wurden " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E W E R T E")
Application.ScreenUpdating = False
'Tabelle einfügen
Set wkb = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksAnzeige = wkb.Worksheets(1)
On Error Resume Next
With wksAnzeige
.Name = "Auswertung"
.Cells(1, 1) = "Suchbegriff"
.Cells(1, 2) = Begriff
.Cells(2, 1) = "Workbook"
.Cells(2, 2) = "Tabelle"
.Cells(2, 3) = "Zelle"
.Cells(3, 1).Select
ActiveWindow.FreezePanes = True
For n = 1 To x - 1
.Cells(n + 2, 1) = xWorkbook(n)
.Cells(n + 2, 2) = xTabelle(n)
.Cells(n + 2, 3) = Adresse(n)
Next n
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Select
End Sub