FIND mit 2 Kriterien, dann Wert übertragen

Forumthread: FIND mit 2 Kriterien, dann Wert übertragen

05.01.2018 15:23:06

Felix

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

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: FIND mit 2 Kriterien, dann Wert übertragen

06.01.2018 00:24:29

Werner
nimm den Code

06.01.2018 02:25:15

Werner

AW: FIND mit 2 Kriterien, dann Wert übertragen

06.01.2018 00:24:29

Werner

Hallo Felix,
teste mal ausgiebig. Ich hab mir das Ergebnis nicht wirklich genauer angeschaut und geprüft ob alles passt.

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

Gruß Werner

nimm den Code

06.01.2018 02:25:15

Werner

Hallo Felix,
nochmal eine kleine Änderung:

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

Gruß Werner

Infobox / Tutorial

Schritt-für-Schritt-Anleitung

Öffne die Excel-Datei: Stelle sicher, dass Du die Arbeitsblätter "Quellblatt" und "Zielblatt" in Deiner Excel-Datei hast.
Öffne den VBA-Editor: Drücke ALT + F11, um den VBA-Editor zu öffnen.
Füge ein neues Modul hinzu: Klicke im Menü auf Einfügen > Modul.

Kopiere den VBA-Code: Füge den folgenden Code in das Modul ein:

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 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

Führe das Makro aus: Schließe den VBA-Editor und gehe zurück zu Excel. Führe das Makro über Entwicklertools > Makros aus.

Häufige Fehler und Lösungen

Fehler: "Objektvariable nicht gesetzt":
- Ursache: Überprüfe, ob die angegebenen Arbeitsblattnamen korrekt sind.
- Lösung: Stelle sicher, dass die Arbeitsblätter "Quellblatt" und "Zielblatt" existieren.
Fehler: Werte werden nicht übertragen:
- Ursache: Möglicherweise stimmen die Suchbegriffe nicht überein.
- Lösung: Vergewissere Dich, dass die Werte in den entsprechenden Spalten und Zeilen vorhanden sind.

Alternative Methoden

Eine alternative Methode, um Werte mit mehreren Kriterien in Excel zu finden, ist die Verwendung von Array-Formeln oder der Funktion SVERWEIS (VLOOKUP). Diese Methoden sind jedoch oft weniger flexibel und erfordern eine gewisse Anpassung der Daten.

Beispiel für SVERWEIS:

=SVERWEIS(A1; 'Quellblatt'!A:B; 2; FALSCH)

Diese Methode funktioniert gut, wenn Du die Daten in einer einzigen Tabelle hast und nur nach einem Kriterium suchst.

Praktische Beispiele

Beispiel 1: Du hast ein Quellblatt mit Produktinformationen und möchtest die Preise auf ein Zielblatt übertragen, wenn die Produkt-ID sowohl im Quellblatt als auch im Zielblatt vorhanden ist.
Beispiel 2: Übertrage Verkaufszahlen aus einem Quellblatt in ein Zielblatt, indem Du die Verkaufsregion und das Produkt als Kriterien verwendest.

Tipps für Profis

Optimierung: Reduziere die Anzahl der Zellen, die Du durchsuchst, um die Performance des Makros zu steigern.
Debugging: Verwende Debug.Print im Code, um Werte während der Ausführung zu überprüfen.
Nutzung von Option Explicit: Stelle sicher, dass Du diese Zeile oben in Deinem Code hast, um Tippfehler in Variablennamen zu vermeiden.

FAQ: Häufige Fragen

1. Wie kann ich den Code anpassen, um weitere Kriterien hinzuzufügen? Du kannst zusätzliche If-Bedingungen innerhalb des Codes hinzufügen, um mehr Kriterien zu berücksichtigen.

2. Funktioniert dieser Code in Excel 2016? Ja, der Code ist kompatibel mit Excel 2016 und allen späteren Versionen, die VBA unterstützen.

3. Was mache ich, wenn der Befehl .Find nicht funktioniert? Überprüfe die Parameter, die Du in der Find-Methode verwendest. Achte darauf, dass die Werte in der richtigen Form vorliegen (z.B. Text oder Zahl).

Beliebteste Forumthreads (12 Monate)

FIND mit 2 Kriterien, dann Wert übertragen

Forumthread: FIND mit 2 Kriterien, dann Wert übertragen

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

FIND mit mehreren Kriterien in Excel VBA

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread