Excel VBA: Nach mehreren Zellwerten suchen

Sub SearchandFind() Dim rng As Range Dim loWert As String loWert = Set rng = Worksheets("Artikelstamm").Range("A:A").Find(loDeinWert) If rng Is Nothing Then MsgBox "Wert " & loDeinWert & " nicht gefunden!" Else rng.EntireRow.Copy Worksheets("VBA").Range("A1").PasteSpecial Paste:=xlPasteAll End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub SearchandFind() Dim rng As Range, loWert$, iLastRowVBA%, iLastRowART%, iCountVBA%, iCountART% iLastRowVBA = Cells(Rows.Count, 1).End(xlUp).Row iLastRowART = Tabelle2.Cells(Rows.Count, 1).End(xlUp).Row For iCountVBA = 2 To iLastRowVBA For iCountART = 2 To iLastRowART If Tabelle2.Range("A" & iCountART).Value = Range("A" & iCountVBA).Value Then Range("B" & iCountVBA & ":D" & iCountVBA).Value = _ Tabelle2.Range("B" & iCountVBA & ":D" & iCountVBA).Value End If Next iCountART Next iCountVBA End Sub

Sub SearchandFind() Dim rng As Range, loWert$, iLastRowVBA%, iLastRowART%, iCountVBA%, iCountART% iLastRowVBA = Cells(Rows.Count, 1).End(xlUp).Row iLastRowART = Tabelle2.Cells(Rows.Count, 1).End(xlUp).Row For iCountVBA = 2 To iLastRowVBA For iCountART = 2 To iLastRowART If Tabelle2.Range("A" & iCountART).Value = Range("A" & iCountVBA).Value Then Range("B" & iCountVBA & ":D" & iCountVBA).Value = _ Tabelle2.Range("B" & iCountART & ":D" & iCountART).Value End If Next iCountART Next iCountVBA End Sub

Sub SearchAndFind() Dim rng As Range, z As Range, suchErg As Range, Eingabe As Range Dim loWert As String, wksVBA As Worksheet, wksArtikel As Worksheet With ThisWorkbook Set wksArtikel = .Worksheets("Artikel") Set wksVBA = .Worksheets("VBA") End With Set rng = wksArtikel.UsedRange Set Eingabe = wksVBA.Range("A2:A" & wksVBA.Cells(wksVBA.Rows.Count, 1).End(xlUp).Row) For Each z In Eingabe On Error Resume Next Set suchErg = rng.Find(z.Value) On Error GoTo 0 If Not suchErg Is Nothing Then wksArtikel.Range(wksArtikel.Cells(suchErg.Row, 2), wksArtikel.Cells(suchErg.Row, _ wksArtikel.Cells(suchErg.Row, Columns.Count).End(xlToRight).Column)).Copy wksVBA.Cells(z.Row, 2).PasteSpecial xlPasteValues 'Else (falls es "Nieten" geben kann) ' wksVBA.Cells(z.Row, 2) = "DEINFEHLERTEXT" End If Next z Set rng = Nothing Set suchErg = Nothing End Sub

Sub yyy() Dim arrStamm, arrVBA Dim i As Long, j As Long, k As Long With Sheets("Artikelstamm") arrStamm = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 5) End With With Sheets("VBA") arrVBA = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)) End With ReDim Preserve arrVBA(1 To UBound(arrVBA), 1 To 5) For i = 1 To UBound(arrVBA) For j = 1 To UBound(arrStamm) If arrStamm(j, 1) = arrVBA(i, 1) Then For k = 2 To 5 arrVBA(i, k) = arrStamm(j, k) Next k End If Next j Next i Sheets("vba").Cells(2, 1).Resize(UBound(arrVBA), UBound(arrVBA, 2)) = arrVBA End Sub

Sub yyy() Dim arrStamm, arrVBA Dim i As Long, j As Long, k As Long Dim objStamm As Object Set objStamm = CreateObject("scripting.dictionary") With Sheets("Artikelstamm") arrStamm = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 5) End With With Sheets("VBA") arrVBA = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)) End With For i = 1 To UBound(arrStamm) objStamm(arrStamm(i, 1)) = i + 1 Next i ReDim Preserve arrVBA(1 To UBound(arrVBA), 1 To UBound(arrStamm, 2)) For i = 1 To UBound(arrVBA) If objStamm.exists(arrVBA(i, 1)) Then For k = 2 To UBound(arrStamm, 2) arrVBA(i, k) = arrStamm(objStamm(arrVBA(i, 1)), k) Next k End If Next i Sheets("vba").Cells(2, 1).Resize(UBound(arrVBA), UBound(arrVBA, 2)) = arrVBA End Sub

Hallo Moritz,
mein Code hält auch die Spalten flexibel! Ich ging davon aus, dass beide Tabellen die gleiche Spaltenanzahl aufweisen.

Sub SuchenUndFinden()
Dim iLastRowVBA%, iLastRowART%, iCountVBA%, iCountART%, iLastCol%, iColART%, arrText
Dim Eingabe As Range, wksVBA As Worksheet, wksART As Worksheet
Set wksVBA = Worksheets("VBA")
Set wksART = Worksheets("ARTIKEL")
Set Eingabe = wksVBA.Range("A2:A" & wksVBA.Cells(wksVBA.Rows.Count, 1).End(xlUp).Row)
iLastRowVBA = wksVBA.UsedRange.SpecialCells(xlCellTypeLastCell).Row
iLastRowART = wksART.UsedRange.SpecialCells(xlCellTypeLastCell).Row
iLastCol = wksVBA.UsedRange.SpecialCells(xlCellTypeLastCell).Column
arrText = Range(Cells(2, 2), Cells(iLastRowVBA, iLastCol))
For iCountVBA = 2 To iLastRowVBA
For iCountART = 1 To iLastRowART
If wksART.Range("A" & iCountART).Value = Range("A" & iCountVBA).Value Then
For iColART = 2 To iLastCol
arrText(iCountVBA - 1, iColART - 1) = wksART.Cells(iCountART, iColART).Value
Next iColART
End If
Next iCountART
Next iCountVBA
Range(Cells(2, 2), Cells(iLastRowVBA, iLastCol)).Value = arrText
End Sub

Servus

Beliebteste Forumthreads (12 Monate)

Excel VBA: Nach mehreren Zellwerten suchen

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel VBA: Nach mehreren Zellwerten suchen

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread