FIND mit 2 Kriterien, dann Wert übertragen

Liebes Forum,
nachdem mir hier schon einmal durch Werner sehr weitergeholfen wurde, habe ich nun erneut ein sehr ähnlich gelagertes Problem, bei dem ich mit meinen bescheidenden VBA Kenntnissen nicht weiterkomme.
Im der nachfolgenden Excel Datei sind 2 Arbeitsblätter. Nun möchte ich gerne per VBA das Excel die Begriffe in Zeile 12 des Quellblattes sowie die Codes in Spalte J mit den Begriffen in Zeile 15 des Zielbalttes sowie den Codes in Spalte P abgleicht. Wenn beides übereinstimmt soll der jeweilige Wert im Quellblatt ins Zielblatt übertragen werden.
Ein Beispiel:
Im Quellblatt steht unter Begriff Lifestyle Code: V203300100 der Wert 24026,33333 (Zelle(16, "Q")). Dieser soll nun per VBA in Zelle(32, "Y") des Zielblattes übertragen werden.
https://www.herber.de/bbs/user/118704.xlsx
Werner hatte mir gestern ein VBA mit dieser Funktion für 1 Kriterium schon geschrieben, welches folgendermaßen aussieht:

Sub Kopieren()
Application.ScreenUpdating = False
With SheetSource
For i = 11 To 51
strSuchbegriff = .Cells(12, i)
Set raFund = SheetDestination.Rows(15).Find(strSuchbegriff _
, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not raFund Is Nothing Then
SheetDestination.Cells(31, raFund.Column).Value _
= .Cells(15, i).Value
End If
Next i
End With
Set SheetSource = Nothing: Set SheetDestination = Nothing: Set raFund = Nothing
Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub

Leider habe ich es nicht geschafft es so zu erweitern das es für die ganze Tabelle klappt, vllt. kann mir hier nochmal jemand weiterhelfen. Vielen dank schon Mal.
Viele Grüße
Felix

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub Kopieren() Dim loLetzteZiel As Long, i As Long, strSuch As String Dim raZielZeile As Range, raZielBereich As Range, raZelle As Range Dim raQuellBereich As Range, raZielSpalte As Range Dim wsQ As Worksheet, wsZ As Worksheet Set wsQ = ThisWorkbook.Worksheets("Quellblatt") Set wsZ = ThisWorkbook.Worksheets("Zielblatt") Application.ScreenUpdating = False With wsZ loLetzteZiel = .Cells(.Rows.Count, 16).End(xlUp).Row Set raZielBereich = .Range(.Cells(16, 16), .Cells(loLetzteZiel, 16)) For Each raZelle In raZielBereich.SpecialCells(xlCellTypeConstants) Set raZielZeile = wsQ.Columns(10).Find(raZelle.Value, lookat:=xlWhole _ , LookIn:=xlValues, MatchCase:=True) If Not raZielZeile Is Nothing Then For i = 11 To 51 strSuch = wsQ.Cells(12, i) Set raZielSpalte = wsZ.Rows(15).Find(strSuch, lookat:=xlWhole _ , LookIn:=xlValues, MatchCase:=True) If Not raZielSpalte Is Nothing Then .Cells(raZielZeile.Row, raZielSpalte.Column) = _ .Cells(raZielZeile.Row, raZielSpalte.Column) + wsQ.Cells(raZelle.Row, i) End If Next i End If Next raZelle End With Set wsQ = Nothing: Set wsZ = Nothing Set raZielBereich = Nothing: Set raZielZeile = Nothing: Set raZielSpalte = Nothing Application.ScreenUpdating = True End Sub

Option Explicit Public Sub Kopieren() Dim loLetzteZiel As Long, i As Long, strSuch As String Dim raQuellZeile As Range, raZielBereich As Range, raZelle As Range Dim raQuellBereich As Range, raZielSpalte As Range Dim wsQ As Worksheet, wsZ As Worksheet Set wsQ = ThisWorkbook.Worksheets("Quellblatt") Set wsZ = ThisWorkbook.Worksheets("Zielblatt") Application.ScreenUpdating = False With wsZ loLetzteZiel = .Cells(.Rows.Count, 16).End(xlUp).Row Set raZielBereich = .Range(.Cells(16, 16), .Cells(loLetzteZiel, 16)) For Each raZelle In raZielBereich.SpecialCells(xlCellTypeConstants) Set raQuellZeile = wsQ.Columns(10).Find(raZelle.Value, lookat:=xlWhole _ , LookIn:=xlValues, MatchCase:=True) If Not raQuellZeile Is Nothing Then For i = 11 To 51 strSuch = wsQ.Cells(12, i) Set raZielSpalte = wsZ.Rows(15).Find(strSuch, lookat:=xlWhole _ , LookIn:=xlValues, MatchCase:=True) If Not raZielSpalte Is Nothing Then .Cells(raZelle.Row, raZielSpalte.Column) = _ .Cells(raZelle.Row, raZielSpalte.Column) _ + wsQ.Cells(raQuellZeile.Row, i) End If Next i End If Next raZelle End With Set wsQ = Nothing: Set wsZ = Nothing Set raZielBereich = Nothing: Set raQuellZeile = Nothing: Set raZielSpalte = Nothing Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

FIND mit 2 Kriterien, dann Wert übertragen

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

191 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

FIND mit 2 Kriterien, dann Wert übertragen

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

191 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