Werte suchen und in neuer Tabelle auflisten

Hallo Forum,
ich habe eine Tabelle mit ca. 200 Artikelnummern. Ich möchte nun in meiner PERSONL.xls ein Makro erstellen, mit dem ich jede beliebige aktive Arbeitsmappe nach diesen 200 Artikelnummern durchsuchen kann (ähnlich wie die Funktion "Bearbeiten-Suchen" aus dem Menü). Nur will ich nicht nur eine, sondern 200 Artikelnummern suchen. Sobald im aktiven Sheet eine oder mehrere Nummern vorkommen, soll Excel ein neues Sheet öffnen und die gefundenen Nummern nacheinander auflisten.
Hier die Liste mit den Artikelnummern (in diesem Beispiel nur 5)
https://www.herber.de/bbs/user/46602.xls
Ich habe mich im Archiv umgesehen und einen ähnlichen Beitrag gefunden, von Ralf Zenker am 05.10.07. Er wollte bei Auffinden der Nummer einen Buchstaben ersetzt haben. Leider habe ich (noch) nicht genug VBA-Kenntnisse, um mir das Makro entsprechend anzupassen, das dort bereits gepostet ist.
Könnt ihr mir helfen - blöde Frage, ich bin sicher, ihr könnt das :-)
Danke schon mal vorab,
viele Grüße
Katja

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub suchen() Dim wks As Worksheet Dim rng As Range, blnFirst As Boolean Dim arrArtikel() As String Dim i As Long, k As Long, lngLR As Long With ThisWorkbook.Sheets("Tabelle1") lngLR = .Cells(Rows.Count, 1).End(xlUp).Row ReDim arrArtikel(lngLR - 2) For i = 2 To lngLR arrArtikel(i - 2) = .Cells(i, 1).Text Next End With For i = 0 To UBound(arrArtikel) Set rng = ActiveSheet.Cells.Find(arrArtikel(i)) If Not rng Is Nothing Then If Not blnFirst Then Set wks = Sheets.Add(, Sheets(Sheets.Count)) blnFirst = True Else Set wks = Sheets(Sheets.Count) End If k = k + 1 wks.Cells(k, 1) = arrArtikel(i) End If Next End Sub

besser ist, man testet den Code vorher...
hier die Korrektur
Gruß
Christian


Option Explicit
Public Sub suchen()
Dim wksRes As Worksheet, wksSrch As Worksheet
Dim rng As Range, blnFirst As Boolean
Dim arrArtikel() As String
Dim i As Long, k As Long, lngLR As Long
With ThisWorkbook.Sheets("Tabelle1")
lngLR = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim arrArtikel(lngLR - 2)
For i = 2 To lngLR
arrArtikel(i - 2) = .Cells(i, 1).Text
Next
End With
Set wksSrch = ActiveSheet
For i = 0 To UBound(arrArtikel)
Set rng = wksSrch.Cells.Find(arrArtikel(i))
If Not rng Is Nothing Then
If Not blnFirst Then
Set wksRes = Sheets.Add(, Sheets(Sheets.Count))
blnFirst = True
Else
Set wksRes = Sheets(Sheets.Count)
End If
k = k + 1
wksRes.Cells(k, 1) = arrArtikel(i)
End If
Next
Set rng = Nothing
Set wksSrch = Nothing
Set wksRes = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Werte suchen und in neuer Tabelle auflisten

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte suchen und in neuer Tabelle auflisten

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread