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
<em> <strong>Adr1 = f.Address
Do
</strong></em>
j = f.Row
<strong><em>
Set
f = t1.Columns(
"E"
).FindNext(f)
Loop
While
Not
f
Is
Nothing
And
f.Address <> Adr1</em></strong>
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