Zuordnungen anhand von Produktnummern

Hallo!
Folgendes Problem habe ich:
Es bestehen in einer Arbeitsmappe drei Listen.
In Liste 1 sind Produktnummern aufgefuehrt. Hierzu sollen Preise eingetragen werden.
In Liste 2 sind Produktnummern, Preise und ein Code zu finden.
In Liste 3 sind weitere Produktnummern, Preise und ein Code zu finden.
(es handelt sich um sehr viele Eintraege, so dass zwei Listen benoetigt werden).
Die Aufgabe: Erst soll in Liste 1 die erste Produktnummer genommen werden, um anschliessend in Liste 2 und 3 zu schauen, ob diese Produktnummer dort auch aufgefuehrt ist.
Wenn nicht: Preisfeld in Liste 1 leer lassen.
Wenn ja: Preis von Liste 2 oder 3 in Liste 1 kopieren, wobei der Preis von Liste 2 noch anhand des Codes modifiziert wird:
- wenn Code = 1: gleicher Preis soll in Liste 1 eingetragen werden.
- wenn Code = 2: Preis soll durch hundert geteilt werden und so in Liste 1 eingetragen werden
- wenn Code = 3: Preis soll durch 1000 geteilt werden und so in Liste 1 eingetragen werden.
Es soll exakt nach den Produktnummern gesucht werden (und nicht nur nach dem String), da evtl. eine Produktnummer von einer anderen ein String ist.
Es handelt sich um 5 mal den gleichen Vorgang (also 5 mal jeweils drei Listen) und jeweils etwa 300 zuzuordnende Produktnummern.
Das ganze habe ich in einer Beispieldatei (mit Resultat) dargestellt: https://www.herber.de/bbs/user/13541.xls
Koenntet Ihr mir helfen? Danke!
Arpad

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Arpad,
wie gefällt Dir dieser Makro-Vorschlag?


Sub Arpad()
Dim SuBe As Range
Dim s As String
Dim dW As Double
Dim laR1 As Long, laR2 As Long, laR3 As Long, i As Long
Application.ScreenUpdating = False
Sheets("Liste 1").Select
laR1 = Cells(Rows.Count, 1).End(xlUp).Row
laR2 = Sheets("Liste 2").Cells(Rows.Count, 1).End(xlUp).Row
laR3 = Sheets("Liste 3").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To laR1
s = Cells(i, 1).Text
With Sheets("Liste 2")
Set SuBe = .Range(.Cells(2, 1), .Cells(laR2, 1)). _
Find(s, lookat:=xlWhole)
If Not SuBe Is Nothing Then
dW = .Cells(SuBe.Row, 2).Value
If .Cells(SuBe.Row, 3).Value = 2 Then
dW = dW / 100
ElseIf .Cells(SuBe.Row, 3).Value = 3 Then
dW = dW / 1000
End If
Cells(i, 2).Value = dW
End If
End With
If SuBe Is Nothing Then
With Sheets("Liste 3")
Set SuBe = .Range(.Cells(2, 1), .Cells(laR3, 1)). _
Find(s, lookat:=xlWhole)
If Not SuBe Is Nothing Then
dW = .Cells(SuBe.Row, 2).Value
If .Cells(SuBe.Row, 3).Value = 2 Then
dW = dW / 100
ElseIf .Cells(SuBe.Row, 3).Value = 3 Then
dW = dW / 1000
End If
Cells(i, 2).Value = dW
End If
End With
End If
Set SuBe = Nothing
Next i
Application.ScreenUpdating = True
End Sub

Viel Erfolg wünscht
WernerB.
P.S.: Dieses Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter !

Beliebteste Forumthreads (12 Monate)

Zuordnungen anhand von Produktnummern

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread