Sub Beispiel()
Dim ergebnis
ergebnis = zweiD(Tabelle1.Range("A4:B7"), Tabelle1.Range("D4:E12"))
Tabelle1.Range("J18").Resize(UBound(ergebnis), 3) = ergebnis
End Sub
Function zweiD(bb As Range, aa As Range)
Dim a, b, c
Dim ia As Long, ib As Long, ic As Long, nc As Long
a = aa.Value
b = bb.Value
ReDim c(1 To 3, 1 To UBound(a) + UBound(b))
For ic = 1 To UBound(c, 2): c(3, ic) = -100000: Next
ia = 1
ib = 1
ic = 0
Do
Do While a(ia, 1) <= b(ib, 1)
ic = ic + 1
c(1, ic) = a(ia, 1)
c(2, ic) = a(ia, 2)
ia = ia + 1
If ia > UBound(a, 1) Then Exit Do
Loop
If ic > 0 Then
If b(ib, 1) = c(1, ic) Then
c(3, ic) = b(ib, 2)
ib = ib + 1
End If
End If
If ia > UBound(a, 1) Or ib > UBound(b, 1) Then Exit Do
Do While b(ib, 1) <= a(ia, 1)
ic = ic + 1
c(1, ic) = b(ib, 1)
c(3, ic) = b(ib, 2)
ib = ib + 1
If ib > UBound(b, 1) Then Exit Do
Loop
If a(ia, 1) = c(1, ic) Then
c(2, ic) = a(ia, 2)
ia = ia + 1
End If
If ia > UBound(a, 1) Or ib > UBound(b, 1) Then Exit Do
Loop
Do While ia <= UBound(a, 1)
ic = ic + 1
c(1, ic) = a(ia, 1)
c(2, ic) = a(ia, 2)
ia = ia + 1
Loop
Do While ib <= UBound(b, 1)
ic = ic + 1
c(1, ic) = b(ib, 1)
c(3, ic) = b(ib, 2)
ib = ib + 1
Loop
nc = ic
ReDim Preserve c(1 To 3, 1 To nc)
ia = 1
Do While c(3, ia) = -100000: ia = ia + 1: Loop
Do
If c(3, ia) = -100000 Then
ia = ia - 1
ib = ia + 1
Do While c(3, ib) = -100000
ib = ib + 1
If ib > UBound(c, 2) Then
ib = ia - 1
Exit Do
End If
Loop
For ic = ia + 1 To IIf(ib < ia, nc, ib - 1)
c(3, ic) = c(3, ia) + (c(3, ib) - c(3, ia)) / (c(1, ib) - c(1, ia)) * (c(1, ic) - c(1, ia))
Next
ia = ic - 1
End If
ia = ia + 1
Loop While ia < nc
zweiD = Application.Transpose(c)
End Function