|
zum Bleistift :
Option Explicit
Sub WertZuSpalte()
Const tSh1 As String = "Tabelle1" 'Tabelle wo Daten
Const arow As Long = 1 'Zeile wo Angabe
Const wCol As Long = 2 'Spalte wo Wert
Const tSh2 As String = "Tabelle2" 'Zieltabelle
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
|