Option
Explicit
Sub
WertZuSpalte()
Const
tSh1
As
String
=
"Tabelle1"
Const
arow
As
Long
= 1
Const
wCol
As
Long
= 2
Const
tSh2
As
String
=
"Tabelle2"
Dim
Sh1
As
Worksheet
Dim
Sh2
As
Worksheet
Dim
x
As
Long
, y
As
Long
Dim
sRng
As
Range, zRng
As
Range, c
As
Range, k
As
Range, z
As
Range
Set
Sh1 = Sheets(tSh1)
Set
Sh2 = Sheets(tSh2)
Rem säubern ggf.
With
Sh2
.Cells.Clear
Set
z = [A1]
End
With
With
Sh1
Rem benutzter Bereich
x = .Cells.Find(
"*"
, [A1], , , xlByRows, xlPrevious).Row
y = .Cells.Find(
"*"
, [A1], , , xlByColumns, xlPrevious).Column
Rem WerteSpalte
Set
sRng = Range(.Cells(2, wCol), .Cells(x, wCol))
Rem abarbeiten
For
Each
c
In
sRng
Rem Suchbereich
Set
zRng = Range(.Cells(c.Row, wCol + 1), .Cells(c.Row, y))
Rem durchlaufen
For
Each
k
In
zRng
Rem Bedingung
If
k.Value > c.Value
Then
Rem Aktion
z.Value = c.Offset(0, -1).Value
z.Offset(0, 1).Value = .Cells(arow, k.Column).Value
Rem nächste Zeile
Set
z = z.Offset(1, 0)
Rem fertig
Exit
For
End
If
Next
k
Next
c
End
With
End
Sub