Suchen und auflisten
19.11.2014 17:03:37
Gregor
Ich will in einem Bereich auf Blatt Muster1 nach einem Suchbegriff suchen und die Spalte 1 und _ 2 der Zeile des gefundenen Suchbegriffes in Blatt Muster2 in die Zeile des Suchbegriffs übertragen. Die Suchbefriffe können mehrmals vorkommen. Dazu habe ich folgenden Code geschrieben:
Sub Suchen_und_auflisten()
Dim Bereich As Range
Dim rng As Range
Dim sFind As String
Worksheets("Muster1").Activate
Set Bereich = Worksheets("Muster1").Range(Cells(3, 78), Cells(129, 125))
IntLastRow = Worksheets("Muster2").Cells(Rows.Count, 1).End(xlUp).Row
For Start = 2 To IntLastRow
sFind = Worksheets("Muster2").Cells(Start, 1)
Spalte = 31
For Each rng In Bereich
If InStr(rng, sFind) Then
Worksheets("Muster2").Cells(Start, Spalte) = Worksheets("Muster1").Cells(rng. _
Row, 2)
Worksheets("Muster2").Cells(Start, Spalte + 1) = Worksheets("Muster1").Cells( _
rng.Row, 1)
Spalte = Spalte + 2
End If
Next
Next Start
End Sub
Soweit so gut, nur geht das etwas lange und zudem will ich doppelte Einträge (Überträge) aus Blatt Muster1 nur einmal in Blatt Muster2 übertagen. Vermutlich geht das schneller mit arrDaten(). Und wie kann ich doppelte Überträge vermeiden?
Vielen Dank und Gruss
Gregor
Anzeige