Teilstring in Zellen suchen und Zellinhalt kopiere

Sub test() Dim such, Bereich such = "test" For i = 1 To 8 If InStr(1, Cells(i, 1).Value, such, 1) Then Bereich = Bereich + Cells(i, 1).AddressLocal(False, False) & "," End If Next Bereich = Left(Bereich, Len(Bereich) - 1) Range(Bereich).EntireRow.Copy Destination:=Worksheets("Tabelle2").Cells(1, 1) End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub teilstring_suche() Dim Daten As Range Dim teilwörter Dim zeile As Long Dim eintrag As Long Dim treffer As Object teilwörter = Tabelle2.Range(Tabelle2.Cells(1, 1), Tabelle2.Cells(Tabelle2.Cells(Tabelle2.Rows. _ Count, 1).End(xlUp).Row, 2)) Set Daten = Tabelle1.Range(Tabelle1.Cells(1, 7), Tabelle1.Cells(Tabelle1.Cells(Tabelle1.Rows. _ Count, 7).End(xlUp).Row, 7)) eintrag = 1 For zeile = 1 To UBound(teilwörter, 1) Set treffer = Daten.Find(teilwörter(zeile, 1), , , xlPart) If Not treffer Is Nothing Then teilwörter(eintrag, 2) = teilwörter(zeile, 1) eintrag = eintrag + 1 End If Next Tabelle2.Range(Tabelle2.Cells(1, 1), Tabelle2.Cells(Tabelle2.Cells(Tabelle2.Rows.Count, 1).End( _ xlUp).Row, 2)) = teilwörter End Sub

Moin!
Upps, dann war das ein Missverständnis. Dann ändert sich der Code ein wenig. Zum Löschen hätte ich jetzt einfach die Spalte B gelöscht - ist schon mit dabei.

Sub teilstring_suche()
Dim Daten As Range
Dim teilwörter
Dim ergebnis As Object
Dim zeile As Long
Dim treffer As Object
Dim teffer1
teilwörter = Tabelle2.Range(Tabelle2.Cells(1, 1), Tabelle2.Cells(Tabelle2.Cells(Tabelle2.Rows. _
Count, 1).End(xlUp).Row, 1))
Set Daten = Tabelle1.Range(Tabelle1.Cells(1, 7), Tabelle1.Cells(Tabelle1.Cells(Tabelle1.Rows. _
Count, 7).End(xlUp).Row, 7))
Set ergebnis = CreateObject("Scripting.Dictionary")
'lösht die Spalte
Tabelle2.Columns("b").ClearContents
For zeile = 1 To UBound(teilwörter, 1)
Set treffer = Daten.Find(teilwörter(zeile, 1), , , xlPart)
If Not treffer Is Nothing Then
treffer1 = treffer.Address
Do
If Not ergebnis.exists(treffer.Value) Then ergebnis.Add treffer.Value, 1
Set treffer = Daten.FindNext(treffer)
Loop While Not treffer Is Nothing And treffer.Address  treffer1
End If
Next
Tabelle2.Range(Tabelle2.Cells(1, 2), Tabelle2.Cells(ergebnis.Count, 2)) = Application.Transpose( _
ergebnis.keys)
End Sub

Sub teilstring_suche() Dim Daten As Range Dim teilwörter Dim ergebnis As Object Dim zeile As Long Dim treffer As Object Dim teffer1 teilwörter = Tabelle2.Range(Tabelle2.Cells(2, 1), Tabelle2.Cells(Tabelle2.Cells(Tabelle2.Rows. _ Count, 1).End(xlUp).Row, 1)) Set Daten = Tabelle1.Range(Tabelle1.Cells(2, 7), Tabelle1.Cells(Tabelle1.Cells(Tabelle1.Rows. _ Count, 7).End(xlUp).Row, 7)) Set ergebnis = CreateObject("Scripting.Dictionary") 'löscht die Spalte ab Zeile 2 If Tabelle2.Cells(2, 2) "" Then Tabelle2.Range("B2:B" & Tabelle2.Cells(Tabelle2.Rows.Count, _ 2).End(xlUp).Row).ClearContents For zeile = 1 To UBound(teilwörter, 1) Set treffer = Daten.Find(teilwörter(zeile, 1), , , xlPart) If Not treffer Is Nothing Then treffer1 = treffer.Address Do If Not ergebnis.exists(treffer.Value) Then ergebnis.Add treffer.Value, 1 Set treffer = Daten.FindNext(treffer) Loop While Not treffer Is Nothing And treffer.Address treffer1 End If Next Tabelle2.Cells(2, 2).Resize(ergebnis.Count) = Application.Transpose(ergebnis.keys) End Sub

Beliebteste Forumthreads (12 Monate)

Teilstring in Zellen suchen und Zellinhalt kopiere

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Teilstring in Zellen suchen und Zellinhalt kopiere

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

311 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread