Hallo,

hier mein Vorschlag. Du hast auf das Herberforum verlinkt, hast du dort auch gefragt und hast du dort eine Antwort bekommen?

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)        'bitte gib der Funktion einen besseren Namen
Dim a, b, c
Dim ia As Long, ib As Long, ic As Long, nc As Long
'Daten aus den Ranges in Arrays
a = aa.Value
b = bb.Value

'Neues Array für alle Daten (transponiert wegen redim preserve)
ReDim c(1 To 3, 1 To UBound(a) + UBound(b))
For ic = 1 To UBound(c, 2):  c(3, ic) = -100000:      Next

'Werte in Array c verteilen
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                                 'Zeilenanzahl
ReDim Preserve c(1 To 3, 1 To nc)       'gestutzt



'lin. Interpolation in den Lücken von c(3,*), mit nicht äquidistanten x-Werten c(1,*)
ia = 1
Do While c(3, ia) = -100000:    ia = ia + 1:   Loop     'keinen Extrapolation am Anfang
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  'Extrapolation am Ende
                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