|
Hallo soupy,
ist es richtig, dass für jedes i das größte j, für das deine Forderung erfüllt wird, für die Kopie Worksheets("Tabelle1").Cells(i, 13).Value = Worksheets("Tabelle2").Cells(j, 6).Value verwendet werden soll, weil ja dein Code im Falle mehrere geeignetet j die früheren Kopien überschreibt.
Wenn du deine j-Schleife von hinten beginnst, könntest du dann im Falle einer Übereinstimmung sofort mit Exit for aussteigen und Zeit sparen. Ich fürchte, dass das Makro dennoch viel Zeit braucht. Versuche daher mal einen anderen Ansatz mit dem Find-Objekt:
Sub Zuordnung()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set t1 = ActiveWorkbook.Worksheets("Tabelle3")
Set t2 = ActiveWorkbook.Worksheets("Tabelle3")
For i = 2 To t1.Cells(Rows.Count, 1).End(xlUp).Rows.Row
Set f = t1.Columns("E").Find(What:=t2.Cells(i, 1))
If Not f Is Nothing Then
Adr1 = f.Address
Do
j = f.Row
Set f = t1.Columns("E").FindNext(f)
Loop While Not f Is Nothing And f.Address <> Adr1
For k = 2 To 5
If t1.Cells(i, k + 5) = t2.Cells(j, k) Then Exit For
Next k
If k < 6 Then t1.Cells(i, 13) = t2.Cells(j, 6)
End If
Next i
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Wenn nur eine Übereinstimmung möglich ist oder die erste verwendet werden soll, kannst du auf die fest und kursiv dargestellen Zeilen verzichten.
Rückmeldung wäre schön.
Gruß
Holger
|