Die Datei https://www.herber.de/bbs/user/2097.xls wurde aus Datenschutzgründen gelöscht
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rErg As Range
If Target.Address(0, 0) = "B1" Then
Set rErg = Worksheets("Ursprung").[A:A].Find(Target, , xlWhole)
If Not rErg Is Nothing Then
Set rErg = rErg.Offset(0, 1)
With Target.Offset(1)
.Value = rErg
.Font.ColorIndex = rErg.Font.ColorIndex
.Interior.ColorIndex = rErg.Interior.ColorIndex
.Font.Bold = rErg.Font.Bold
.Font.Italic = rErg.Font.Italic = True
End With
Else
Target.Offset(1) = "#NV"
End If
End If
End Sub
Function SverweisSpecial(SuchKr As Range, TabelleName As String, Matrix As Range, SpaltenIndex As Integer) As Variant
Dim WS As Worksheet, Rng As Range, RngZiel As Range, RngQuelle As Range
Application.Volatile
Set WS = Worksheets(TabelleName)
Set Rng = WS.Range(WS.Cells(Matrix.Row, Matrix.Column), WS.Cells(Matrix.Row + Matrix.Rows.Count - 1, Matrix.Column))
Set RngZiel = WS.Cells(Rng.Row + WorksheetFunction.Match(SuchKr, Rng, 0) - 1, Rng.Column + SpaltenIndex - 1)
Set RngQuelle = Application.Caller
RngQuelle.Interior.ColorIndex = RngZiel.Interior.ColorIndex
RngQuelle.Interior.ColorIndex = RngZiel.Font.ColorIndex
SverweisSpecial = RngZiel.Interior.ColorIndex
End Function
