Mit VBA aus einer Liste suchen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Suchen_starten() Dim AC As Range, rFind As Range Dim j, sp As Integer, lz1 As Long, firstAddress As String With Worksheets("Suchordner") lz1 = .Cells(Rows.Count, 3).End(xlUp).Row .Range("D8:H500").ClearContents Application.ScreenUpdating = False For Each AC In .Range("C8:C" & lz1) sp = 4 '1. Spalte zum auflisten For j = 2 To Worksheets.Count If Worksheets(j).Name "Suchordner" Then Set rFind = Worksheets(j).Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do .Cells(AC.Row, sp) = rFind.Row & " " & Worksheets(j).Name sp = sp + 1 Set rFind = Worksheets(j).Cells.FindNext(rFind) 'Nächstes Finden Loop While Not rFind Is Nothing And rFind.Address firstAddress End If End If Next j Next AC End With MsgBox "fertig" End Sub

Sub Suchen_starten() Dim AC As Range, rFind As Range Dim j, sp As Integer, lz1 As Long, firstAddress As String Dim Ext As String, St As Integer With Worksheets("Suchordner") lz1 = .Cells(Rows.Count, 3).End(xlUp).Row .Range("D8:H500").ClearContents Application.ScreenUpdating = False For Each AC In .Range("C8:C" & lz1) sp = 4 '1. Spalte zum auflisten For j = 2 To Worksheets.Count If Worksheets(j).Name "Suchordner" Then Set rFind = Worksheets(j).Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do St = InStr(rFind, ".") 'Stelle des Punktes Ext = Mid(rFind, St) 'Dateiendung Select Case Ext 'nur Video Formate Case ".dvr-ms", ".Mpg", ".Mp4", ".ts", ".ts.ap", ".ts.sc", ".VOB", ".tv" .Cells(AC.Row, sp) = rFind.Row & " " & Worksheets(j).Name sp = sp + 1 Case Else 'nix End Select Set rFind = Worksheets(j).Cells.FindNext(rFind) 'Nächstes Finden Loop While Not rFind Is Nothing And rFind.Address firstAddress End If End If Next j Next AC End With MsgBox "fertig" End Sub

Sub Suchen_starten() Dim AC As Range, X As Range, i Dim W As Worksheet Dim rFind As Range Dim firstAddress As String With Worksheets("Suchordner") .Range("A19:ZZ500").ClearContents For i = 5 To 12: .Range("A19:ZZ500").Borders(i).LineStyle = xlNone: Next 'Rahmen löschen Application.ScreenUpdating = False For Each AC In .Range(.Range("C8"), .Range("C99999").End(xlUp)).Cells With .Cells(Application.Max(19, .Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) + 1, "C") .Value = AC .Resize(1, 2).Borders(xlEdgeTop).LineStyle = xlContinuous End With For Each W In Worksheets If W.Name "Suchordner" Then Set rFind = W.Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do Select Case LCase(Mid(rFind, InStrRev(rFind, "."))) 'Dateiendung in Kleinschrift Case ".dvr-ms", ".mpg", ".mp4", ".ts", ".ts.ap", ".ts.sc", ".vob", ".tv" 'nur Video Formate ActiveSheet.Hyperlinks.Add _ Anchor:=.Cells(Application.Max(.Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) + 1, "D"), _ Address:="", SubAddress:=rFind.Worksheet.Name & "!" & rFind.Address, _ TextToDisplay:=rFind.Value End Select Set rFind = W.Cells.FindNext(rFind) 'Nächstes Finden Loop While rFind.Address firstAddress End If End If Next W Next AC End With Application.ScreenUpdating = True MsgBox "fertig" End Sub

Sub Suchen_starten() Dim AC As Range, X As Range, i Dim W As Worksheet Dim rFind As Range Dim firstAddress As String With Worksheets("Suchordner") .Range("A19:ZZ500").ClearContents For i = 5 To 12: .Range("A19:ZZ500").Borders(i).LineStyle = xlNone: Next 'Rahmen löschen Application.ScreenUpdating = False For Each AC In .Range(.Range("C8"), .Range("C99999").End(xlUp)).Cells With .Cells(Application.Max(19, .Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) + 1, "C") .Value = AC .Resize(1, 2).Borders(xlEdgeTop).LineStyle = xlContinuous End With For Each W In Worksheets If W.Name "Suchordner" Then Set rFind = W.Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do If InStrRev(rFind, ".") > 0 Then Select Case LCase(Mid(rFind, InStrRev(rFind, "."))) 'Dateiendung (nach dem letzten Punkt, in Kleinschrift) Case ".dvr-ms", ".mpg", ".mp4", ".ts", ".ts.ap", ".ts.sc", ".vob", ".tv" 'nur Video Formate ActiveSheet.Hyperlinks.Add _ Anchor:=.Cells(Application.Max(.Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) + 1, "D"), _ Address:="", SubAddress:="'" & rFind.Worksheet.Name & "'!" & rFind.Address, _ TextToDisplay:=rFind.Value End Select End If Set rFind = W.Cells.FindNext(rFind) 'Nächstes Finden Loop While rFind.Address firstAddress End If End If Next W Next AC End With Application.ScreenUpdating = True MsgBox "fertig" End Sub

Sub Suchen_starten() Dim AC As Range, X As Range, i Dim W As Worksheet Dim rFind As Range Dim firstAddress As String With Worksheets("Suchordner") .Range("A19:ZZ500").ClearContents For i = 5 To 12: .Range("A19:ZZ500").Borders(i).LineStyle = xlNone: Next 'Rahmen löschen Application.ScreenUpdating = False For Each AC In .Range(.Range("C8"), .Range("C99999").End(xlUp)).Cells With .Cells(Application.Max(19, .Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) + 1, "C") .Value = AC .Resize(1, 3).Borders(xlEdgeTop).LineStyle = xlContinuous End With For Each W In Worksheets If W.Name "Suchordner" Then Set rFind = W.Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do If InStrRev(rFind, ".") > 0 Then Select Case LCase(Mid(rFind, InStrRev(rFind, "."))) 'Dateiendung (nach dem letzten Punkt, in Kleinschrift) Case ".dvr-ms", ".mpg", ".mp4", ".ts", ".ts.ap", ".ts.sc", ".vob", ".tv" 'nur Video Formate i = Application.Max(.Range("C99999").End(xlUp).Row, .Range("D99999").End(xlUp).Row) ActiveSheet.Hyperlinks.Add _ Anchor:=.Cells(i + 1, "D"), _ Address:="", SubAddress:="'" & rFind.Worksheet.Name & "'!" & rFind.Address, _ TextToDisplay:=rFind.Value .Cells(i + 1, "E") = "'" & rFind.Worksheet.Name & "'!" & rFind.Address(0, 0) End Select End If Set rFind = W.Cells.FindNext(rFind) 'Nächstes Finden Loop While rFind.Address firstAddress End If End If Next W Next AC End With Application.ScreenUpdating = True MsgBox "fertig" End Sub

Sub Suchen_starten() Dim AC As Range, X As Range, i Dim W As Worksheet Dim rFind As Range Dim Lo As ListObject Dim firstAddress As String With Worksheets("Suchordner") Application.ScreenUpdating = False Set Lo = ListObject_HerstellenLeeren(.Cells.Worksheet) .Range("A21") = 0 'Dummy-Eintrag bei leerem ListObject For Each AC In .Range("C8").CurrentRegion.Columns(2).Cells For Each W In Worksheets If W.Name "Suchordner" Then Set rFind = W.Cells.Find(What:=AC, After:=[a1], LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then firstAddress = rFind.Address Do If InStrRev(rFind, ".") > 0 Then Select Case LCase(Mid(rFind, InStrRev(rFind, "."))) 'Dateiendung (nach dem letzten Punkt, in Kleinschrift) Case ".dvr-ms", ".mpg", ".mp4", ".ts", ".ts.ap", ".ts.sc", ".vob", ".tv" 'nur Video Formate With .Range("A20").End(xlDown) .Offset(1, 0) = .Value + 1 .Offset(1, 1) = AC.Offset(0, -1).Value .Offset(1, 2) = AC.Value ActiveSheet.Hyperlinks.Add Anchor:=.Offset(1, 3), Address:="", _ SubAddress:="'" & rFind.Worksheet.Name & "'!" & rFind.Address, _ TextToDisplay:=rFind.Value .Offset(1, 4) = "'" & rFind.Worksheet.Name & "'!" & rFind.Address(0, 0) End With End Select End If Set rFind = W.Cells.FindNext(rFind) 'Nächstes Finden Loop While rFind.Address firstAddress End If End If Next W Next AC End With Lo.ListRows(1).Delete 'Dummy-Zeile löschen With Lo.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .SortFields.Clear .SortFields.Add Key:=Lo.ListColumns("Nr").Range, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers .SortFields.Add Key:=Lo.ListColumns("Treffer").Range, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers .Apply End With Application.ScreenUpdating = True MsgBox "fertig" End Sub Private Function ListObject_HerstellenLeeren(W As Worksheet) As ListObject Dim Lo As ListObject, i On Error Resume Next With W Set Lo = W.ListObjects(1) If Lo Is Nothing Then W.Range("A20:E20") = Array("Idx", "Nr", "Begriff", "Treffer", "Position") W.ListObjects.Add(xlSrcRange, Range("A20:E20"), , xlYes).Name = "ErgebnisListe" Else For i = 1 To Lo.ListRows.Count: Lo.ListRows(1).Delete: Next End If End With Set ListObject_HerstellenLeeren = Lo End Function

Hallo Elfriede,
das ListObject, diese unbekannte Wesen...
Hinzwischen habe ich vieles darüber gelernt, und die Besonderheiten einigermassen im Griff. Zum Beispiel eine Zeile am Ende eines ListObjects einzufügen ist nicht besonder einfach. Als erste Zeile dagegen sehr. praktisch, da es am Ende sortiert wird. Auch die leeren ListObject sind "sonderbar" zu handeln.
Hier eine neue Version. Kombiniere diese nicht mit andere. Es würde schief gehen. Ich habe übersichtshalber den Code in verschiedenen Subs je nach Aufgaben unterteilt.


Const cErgebnisBlatt = "Suchordner"
Sub Suchen_starten()
Dim AC As Range
Dim LO As ListObject
ThisWorkbook.Activate
With Worksheets(cErgebnisBlatt)
Application.ScreenUpdating = False
Set LO = ListObject_HerstellenLeeren(.Cells.Worksheet)
For Each AC In .Range("C8:C17").Cells
If AC  "" Then Begriff_suchen LO, AC
Next AC
End With
ListObject_sortieren LO, "Nr", xlAscending, "Treffer", xlAscending
Application.ScreenUpdating = True
MsgBox "fertig"
End Sub
Private Sub Begriff_suchen(LO As ListObject, ByVal BegriffZelle As Range)
Dim W As Worksheet
Dim rFind As Range
Dim firstAddress As String
Dim Newline As ListRow
For Each W In Worksheets
If W.Name  cErgebnisBlatt Then
Set rFind = W.Cells.Find(What:=BegriffZelle, After:=[a1], LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not rFind Is Nothing Then
firstAddress = rFind.Address
Do
If InStrRev(rFind, ".") > 0 Then
Select Case LCase(Mid(rFind, InStrRev(rFind, "."))) 'Dateiendung (nach dem letzten Punkt, in Kleinschrift)
Case ".dvr-ms", ".mpg", ".mp4", ".ts", ".ts.ap", ".ts.sc", ".vob", ".tv" 'nur Video Formate
LO.ListRows.Add 1
With LO.ListRows(1).Range
.Range("B1") = BegriffZelle.Offset(0, -1).Value
.Range("C1") = BegriffZelle.Value
LO.Parent.Hyperlinks.Add Anchor:=.Range("D1"), Address:="", _
SubAddress:="'" & rFind.Worksheet.Name & "'!" & rFind.Address, _
TextToDisplay:=rFind.Value
.Range("E1") = "'" & rFind.Worksheet.Name & "'!" & rFind.Address(0, 0)
End With
End Select
End If
Set rFind = W.Cells.FindNext(rFind) 'Nächstes Finden
Loop While rFind.Address  firstAddress
End If
End If
Next W
End Sub
Private Sub ListObject_sortieren(LO As ListObject, ParamArray SpalteUndRichtung())
Dim i
On Error Resume Next
With LO.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.SortFields.Clear
For i = 0 To UBound(SpalteUndRichtung) Step 2
.SortFields.Add Key:=LO.ListColumns(SpalteUndRichtung(i)).Range, SortOn:=xlSortOnValues, Order:=SpalteUndRichtung(i + 1), DataOption:=xlSortTextAsNumbers
Next
.Apply
End With
For i = 1 To LO.ListRows.Count
LO.ListRows(i).Range.Range("A1") = i
Next
End Sub
Private Function ListObject_HerstellenLeeren(W As Worksheet) As ListObject
Dim LO As ListObject
Dim i
On Error Resume Next
With W
Set LO = W.ListObjects(1)
If LO Is Nothing Then
W.ListObjects.Add(xlSrcRange, Range("A20:E20"), , xlYes).Name = "ErgebnisListe"
Else
For i = 1 To LO.ListRows.Count: LO.ListRows(1).Delete: Next
End If
End With
LO.HeaderRowRange = Array("Idx", "Nr", "Begriff", "Treffer", "Position")
Set ListObject_HerstellenLeeren = LO
End Function

VG
Yal

Hallo Elfriede,
ich habe mir erlaubt, auch eine Lösung zu erarbeiten und übermittle Dir hier meine Datei (eigentlich Deine Datei mit meinen Ergänzungen).
https://www.herber.de/bbs/user/151451.xlsm
Das Heraussuchen geht ganz einfach mit nur 2 Klicks. Mit dem ersten Button werden einige Vorbereitungen getroffen: Zunächst werden die Freizeilen (Zeile 3) in den Datentabellen herausgelöscht und anschließend evtl. vorhandene frühere Ergebnisse. Mit dem zweiten Button wird die Suche durchgeführt. Die Ergebnisse erscheinen dann im Suchordner ab der Zeile 42. Es werden jeweils sämtliche Informationen zu den Suchnamen aufgeführt sowie außerdem noch der Tabellenname.
Suchordner. In der Zelle D2 ermittelt das Programm automatisch die Anzahl der vorhandenen Tabellenblätter (die müssen alle denselben Aufbau haben). In der Zelle H8 steht ein Kennzeichen, "1" bedeutet, es werden die Leerzeilen in den Tabellen (Zeile 3) gelöscht und vorhandene frühere Ergebnisse im Suchordner; "0" bedeutet, es werden nur die früheren Ergebnisse gelöscht (weil die Leerzeilen in den Tabellen bereits entfernt wurden). Das Kennzeichen wird vom Programm automatisch von "1" auf "0" gesetzt. Das in der Spalte C einzutragende Suchkriterium bezieht sich jeweils auf die Spalte C in den Datentabellen. Es braucht nicht nach dem kompletten Namen gesucht werden, es kann auch nur ein Teil eingetragen werden, für vorausgehende Zeilentexte oder dem Eintrag nachfolgende Zeilentexte sollte ein "*" (Sternzeichen) verwendet werden. Eintragungen sind auf die Zeilen von C8 bis C34 erlaubt.
Aufbereitung. Dieses Blatt ist für die Titelsuche wichtig. Ich benutze hier die Excel-Funktion für den erweiterten Datenfilter. Jedes Suchkriterium wird damit über die einzelnen Daten-Dateien abgefragt. Werden Eintragungen gefunden, werden diese in den Suchordner übertragen, falls keine Datensätze gefunden wurden, erscheint lediglich der Suchbegriff in dem Suchordner.
Datenbereiche. Hier ist im Programm eine Obergrenze bis zur Zeile 5.000 vorgesehen. Diese Obergrenze läßt sich selbstverständlich anpassen.
Bitte mal ausprobieren, Rückmeldung wäre schön.
Mit freundlichem Gruß
Peter Kloßek

Select Case Ext 'nur Video Formate Case ".dvr-ms", ".Mpg", ".Mp4", ".ts", ".VOB", ".tv" .Cells(AC.Row, sp) = rFind.Row & " " & Worksheets(j).Name sp = sp + 1 Case ".ts.ap", ".ts.cuts", ".ts.meta", ".ts.sc" 'nix Case Else 'nix End Select

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mit VBA aus einer Liste suchen

29 Beiträge zum Forumthread Beiträge zu diesem Forumthread

314 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread