Werte aus Zellen in "Value Like" übergeben

Sub WDVS() Dim a As Long, i As Long Application.ScreenUpdating = False a = 5 For i = 1 To 10000 With Worksheets("Tabelle1") If .Cells(i, "A").Value Like "035 W" And .Cells(i, "A").Value Like "stumpf" And .Cells(i, "A"). _ Value Like "*12*" Then .Rows(i).Copy _ Destination:=Worksheets("Tabelle2").Rows(a) a = a + 1 End If End With Next i Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub WDVS() Dim a As Long, i As Long Dim Such_1 As String, Such_2 As String, Such_3 As String Application.ScreenUpdating = False a = 5 With Worksheets("Tabelle2") Such_1 = .Cells(1, 1).Text Such_2 = .Cells(1, 2).Text Such_3 = "*" & .Cells(1, 3).Text & "*" End With For i = 1 To 10000 With Worksheets("Tabelle1") If .Cells(i, 1).Value Like Such_1 _ And .Cells(i, 1).Value Like Such_2 _ And .Cells(i, 1).Value Like Such_3 Then .Rows(i).Copy Destination:=Worksheets("Tabelle2").Rows(a) a = a + 1 End If End With Next i Application.ScreenUpdating = True End Sub

Hallo Micha,
wenn alle 3 eingegebenen Werte jeweils in der Zelle in Spalte A vorkommen sollen, dann müssen die Suchbegriffe mit zusätzlichen "*" versehen werden. (Variante 1)
Wenn die Werte in Spalte A mit den ersten beiden Begriffen beginnen sollen, gefolgt vom 3. im restlichen Text dann muss du den Suchtext aus den 3 Werten zusammensetzen und vergleichen. (Variante 2)
Gruß
Franz
Beispiel:

Tabellenblattname: Tabelle1
A           B       C
1  035 Wstumpf 0123   1   Zeile 001
2     035 Wstumpf12   2   Zeile 002
3   038 Wstumpf0123   2   Zeile 003
4   035 Xstumpf0123   1   Zeile 004
5   135 Wstumpf0123   3   Zeile 005
6    035 Wstumpf011   4   Zeile 006
7    035 Wstiel0121   5   Zeile 007
8   A035 Wstumpf012   2   Zeile 008
9  035 Wsstumpfa012   3   Zeile 009
10  0d35 Wstumpf0123   1   Zeile 010

Ergebnis mit Makro Variante 1 (mit Variante 2 wird die letzte Zeile nicht kopiert):

Tabellenblattname: Tabelle2
A             B          C
1             035 W   stumpf          12
2
3
4
5  035 Wstumpf 0123        1   Zeile 001
6     035 Wstumpf12        2   Zeile 002
7  035 Wsstumpfa012        3   Zeile 009

Sub WDVS() 'Variante 1
Dim a As Long, i As Long
Dim Such_1 As String, Such_2 As String, Such_3 As String
Application.ScreenUpdating = False
a = 5
With Worksheets("Tabelle2")
Such_1 = .Cells(1, 1).Text & "*"
Such_2 = "*" & .Cells(1, 2).Text & "*"
Such_3 = "*" & .Cells(1, 3).Text & "*"
If .Cells(a, 1)  "" Then
.Range(.Cells(a, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete
End If
End With
With Worksheets("Tabelle1")
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, 1).Value Like Such_1 _
And .Cells(i, 1).Value Like Such_2 _
And .Cells(i, 1).Value Like Such_3 Then
.Rows(i).Copy Destination:=Worksheets("Tabelle2").Rows(a)
a = a + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub WDVS2() 'Variante 2
Dim a As Long, i As Long
Dim Such_1 As String
Application.ScreenUpdating = False
a = 5
With Worksheets("Tabelle2")
Such_1 = .Cells(1, 1).Text & .Cells(1, 2).Text & "*" & .Cells(1, 3).Text & "*"
If .Cells(a, 1)  "" Then
.Range(.Cells(a, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete
End If
End With
With Worksheets("Tabelle1")
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, 1).Value Like Such_1 Then
.Rows(i).Copy Destination:=Worksheets("Tabelle2").Rows(a)
a = a + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

Sub WDVS() Dim a&, n& Dim rngSuchBereich As Range, rngValue As Range, rngTmp As Range 'Suchbereich, Tabelle und Spalte angeben Set rngSuchBereich = Worksheets("Tabelle2").Columns(1) 'Suchwerte, Tabelle und Zellen angeben Set rngValue = Worksheets("Tabelle1").Range("A1:C1") 'erste Einfügezeile a = 5 Application.ScreenUpdating = False With Worksheets("Tabelle1") 'Ziel Tabelle .Range(.Cells(a, 1), .Cells(.Rows.Count, 1)).EntireRow.Delete For Each rngValue In rngValue Set rngTmp = FindDaten(rngValue.Value, rngSuchBereich) If Not rngTmp Is Nothing Then For Each rngTmp In rngTmp.Areas rngTmp.EntireRow.Copy .Cells(a, 1) a = a + rngTmp.Rows.Count Next rngTmp Set rngTmp = Nothing End If Next rngValue End With Application.ScreenUpdating = True End Sub Function FindDaten(strSuchbegriff, rngSuchBereich) As Range Dim strErste$, rngTmp As Range, rngAusgabe As Range Set rngTmp = rngSuchBereich.Find(What:=strSuchbegriff, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False) If rngTmp Is Nothing Then Exit Function Set rngAusgabe = rngTmp strErste = rngTmp.Address Set rngTmp = rngSuchBereich.FindNext(rngTmp) Do While strErste <> rngTmp.Address Set rngAusgabe = Union(rngAusgabe, rngTmp) Set rngTmp = rngSuchBereich.FindNext(rngTmp) Loop Set FindDaten = rngAusgabe End Function

Beliebteste Forumthreads (12 Monate)

Werte aus Zellen in "Value Like" übergeben

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

328 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte aus Zellen in "Value Like" übergeben

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

328 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread